/* 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) ;
}
// 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) ;
}
/**
* @brief Performs QR factorization on a matrix.
*
* @param[in,out] qrd QR factorization of the matrix.
* @param[in] A Matrix to factorize.
* @return 0 on success.
*/
static int cs_fact_init_qr( cs_fact_t *qrd, const cs *A )
{
int order = 3; /* order 0:natural, 1:Chol, 2:LU, 3:QR */
qrd->S = cs_sqr( order, A, 1 );
if (qrd->S == NULL)
goto err_S;
qrd->N = cs_qr( A, qrd->S );
if (qrd->N == NULL)
goto err_N;
qrd->x = cs_malloc( qrd->S->m2, sizeof(double) );
if (qrd->x == NULL)
goto err_x;
qrd->type = CS_FACT_QR;
return 0;
err_x:
cs_nfree( qrd->N );
err_N:
cs_sfree( qrd->S );
err_S:
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, 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;
}
