/* 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) ; }
scs_int factorize(const AMatrix * A, const Settings * stgs, Priv * p) { scs_float *info; scs_int *Pinv, amd_status, ldl_status; cs *C, *K = formKKT(A, stgs); if (!K) { return -1; } amd_status = LDLInit(K, p->P, &info); if (amd_status < 0) return (amd_status); #if EXTRAVERBOSE > 0 if(stgs->verbose) { scs_printf("Matrix factorization info:\n"); #ifdef DLONG amd_l_info(info); #else amd_info(info); #endif } #endif Pinv = cs_pinv(p->P, A->n + A->m); C = cs_symperm(K, Pinv, 1); ldl_status = LDLFactor(C, NULL, NULL, &p->L, &p->D); cs_spfree(C); cs_spfree(K); scs_free(Pinv); scs_free(info); return (ldl_status); }
css *cs_schol(int order, const cs *A) { int n, *c, *post, *P; cs *C; css *S; if (!CS_CSC (A)) return (NULL); /* check inputs */ n = A->n; S = (css *) cs_calloc(1, sizeof(css)); /* allocate result S */ if (!S) return (NULL); /* out of memory */ P = cs_amd(order, A); /* P = amd(A+A'), or natural */ S->pinv = cs_pinv(P, n); /* find inverse permutation */ cs_free(P); if (order && !S->pinv) return (cs_sfree(S)); C = cs_symperm(A, S->pinv, 0); /* C = spones(triu(A(P,P))) */ S->parent = cs_etree(C, 0); /* find etree of C */ post = cs_post(S->parent, n); /* postorder the etree */ c = cs_counts(C, S->parent, post, 0); /* find column counts of chol(C) */ cs_free(post); cs_spfree(C); S->cp = (int *) cs_malloc(n + 1, sizeof(int)); /* allocate result S->cp */ S->unz = S->lnz = cs_cumsum(S->cp, c, n); /* find column pointers for L */ cs_free(c); return ((S->lnz >= 0) ? S : cs_sfree(S)); }
/* 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_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) ; }
// 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; }
/* 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) ; }
/* 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)) ; }
/* Given A, compute coarse and then fine dmperm */ csd *cs_dmperm (const cs *A, int seed) { int m, n, i, j, k, cnz, nc, *jmatch, *imatch, *wi, *wj, *pinv, *Cp, *Ci, *ps, *rs, nb1, nb2, *p, *q, *cc, *rr, *r, *s, ok ; cs *C ; csd *D, *scc ; /* --- Maximum matching ------------------------------------------------- */ if (!CS_CSC (A)) return (NULL) ; /* check inputs */ m = A->m ; n = A->n ; D = cs_dalloc (m, n) ; /* allocate result */ if (!D) return (NULL) ; p = D->p ; q = D->q ; r = D->r ; s = D->s ; cc = D->cc ; rr = D->rr ; jmatch = cs_maxtrans (A, seed) ; /* max transversal */ imatch = jmatch + m ; /* imatch = inverse of jmatch */ if (!jmatch) return (cs_ddone (D, NULL, jmatch, 0)) ; /* --- Coarse decomposition --------------------------------------------- */ wi = r ; wj = s ; /* use r and s as workspace */ for (j = 0 ; j < n ; j++) wj [j] = -1 ; /* unmark all cols for bfs */ for (i = 0 ; i < m ; i++) wi [i] = -1 ; /* unmark all rows for bfs */ cs_bfs (A, n, wi, wj, q, imatch, jmatch, 1) ; /* find C1, R1 from C0*/ ok = cs_bfs (A, m, wj, wi, p, jmatch, imatch, 3) ; /* find R3, C3 from R0*/ if (!ok) return (cs_ddone (D, NULL, jmatch, 0)) ; cs_unmatched (n, wj, q, cc, 0) ; /* unmatched set C0 */ cs_matched (n, wj, imatch, p, q, cc, rr, 1, 1) ; /* set R1 and C1 */ cs_matched (n, wj, imatch, p, q, cc, rr, 2, -1) ; /* set R2 and C2 */ cs_matched (n, wj, imatch, p, q, cc, rr, 3, 3) ; /* set R3 and C3 */ cs_unmatched (m, wi, p, rr, 3) ; /* unmatched set R0 */ cs_free (jmatch) ; /* --- Fine decomposition ----------------------------------------------- */ pinv = cs_pinv (p, m) ; /* pinv=p' */ if (!pinv) return (cs_ddone (D, NULL, NULL, 0)) ; C = cs_permute (A, pinv, q, 0) ;/* C=A(p,q) (it will hold A(R2,C2)) */ cs_free (pinv) ; if (!C) return (cs_ddone (D, NULL, NULL, 0)) ; Cp = C->p ; nc = cc [3] - cc [2] ; /* delete cols C0, C1, and C3 from C */ if (cc [2] > 0) for (j = cc [2] ; j <= cc [3] ; j++) Cp [j-cc[2]] = Cp [j] ; C->n = nc ; if (rr [2] - rr [1] < m) /* delete rows R0, R1, and R3 from C */ { cs_fkeep (C, cs_rprune, rr) ; cnz = Cp [nc] ; Ci = C->i ; if (rr [1] > 0) for (k = 0 ; k < cnz ; k++) Ci [k] -= rr [1] ; } C->m = nc ; scc = cs_scc (C) ; /* find strongly connected components of C*/ if (!scc) return (cs_ddone (D, C, NULL, 0)) ; /* --- Combine coarse and fine decompositions --------------------------- */ ps = scc->p ; /* C(ps,ps) is the permuted matrix */ rs = scc->r ; /* kth block is rs[k]..rs[k+1]-1 */ nb1 = scc->nb ; /* # of blocks of A(R2,C2) */ for (k = 0 ; k < nc ; k++) wj [k] = q [ps [k] + cc [2]] ; for (k = 0 ; k < nc ; k++) q [k + cc [2]] = wj [k] ; for (k = 0 ; k < nc ; k++) wi [k] = p [ps [k] + rr [1]] ; for (k = 0 ; k < nc ; k++) p [k + rr [1]] = wi [k] ; nb2 = 0 ; /* create the fine block partitions */ r [0] = s [0] = 0 ; if (cc [2] > 0) nb2++ ; /* leading coarse block A (R1, [C0 C1]) */ for (k = 0 ; k < nb1 ; k++) /* coarse block A (R2,C2) */ { r [nb2] = rs [k] + rr [1] ; /* A (R2,C2) splits into nb1 fine blocks */ s [nb2] = rs [k] + cc [2] ; nb2++ ; } if (rr [2] < m) { r [nb2] = rr [2] ; /* trailing coarse block A ([R3 R0], C3) */ s [nb2] = cc [3] ; nb2++ ; } r [nb2] = m ; s [nb2] = n ; D->nb = nb2 ; cs_dfree (scc) ; return (cs_ddone (D, C, NULL, 1)) ; }
/* 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"); }
// 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, SEXP keep_dimnames) { CSP A = AS_CSP__(Ap), D; int io = INTEGER(order)[0]; Rboolean verbose = (io < 0);// verbose=TRUE, encoded with negative 'order' int m0 = A->m, m = m0, 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")); int keep_dimnms = asLogical(keep_dimnames); if(keep_dimnms == NA_LOGICAL) { keep_dimnms = TRUE; warning(_("dgcMatrix_QR(*, keep_dimnames = NA): NA taken as TRUE")); } 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' */ SEXP dn = R_NilValue; Rboolean do_dn = FALSE; if(keep_dimnms) { dn = GET_SLOT(Ap, Matrix_DimNamesSym); do_dn = !isNull(VECTOR_ELT(dn, 0)) && m == m0; // FIXME? also deal with case m > m0 ? if(do_dn) { // keep rownames dn = PROTECT(duplicate(dn)); SET_VECTOR_ELT(dn, 1, R_NilValue); } else dn = R_NilValue; } SET_SLOT(ans, Matrix_VSym, Matrix_cs_to_SEXP(N->L, "dgCMatrix", 0, dn)); // "V" Memcpy(REAL(ALLOC_SLOT(ans, Matrix_betaSym, REALSXP, n)), N->B, n); Memcpy(INTEGER(ALLOC_SLOT(ans, Matrix_pSym, INTSXP, m)), p, m); if(do_dn) { UNPROTECT(1); // dn dn = R_NilValue; do_dn = FALSE; } if (ord) { Memcpy(INTEGER(ALLOC_SLOT(ans, install("q"), INTSXP, n)), S->q, n); if(keep_dimnms) { dn = GET_SLOT(Ap, Matrix_DimNamesSym); do_dn = !isNull(VECTOR_ELT(dn, 1)); if(do_dn) { dn = PROTECT(duplicate(dn)); // permute colnames by S->q : cn <- cn[ S->q ] : SEXP cns = PROTECT(duplicate(VECTOR_ELT(dn, 1))); for(int j=0; j < n; j++) SET_STRING_ELT(VECTOR_ELT(dn, 1), j, STRING_ELT(cns, S->q[j])); UNPROTECT(1); SET_VECTOR_ELT(dn, 0, R_NilValue); } else dn = R_NilValue; } } else ALLOC_SLOT(ans, install("q"), INTSXP, 0); SET_SLOT(ans, install("R"), Matrix_cs_to_SEXP(N->U, "dgCMatrix", 0, dn)); if(do_dn) UNPROTECT(1); // dn cs_nfree(N); cs_sfree(S); cs_free(p); UNPROTECT(1); return ans; }