SEXP sparseQR_coef(SEXP qr, SEXP y)
{
SEXP ans = PROTECT(dup_mMatrix_as_dgeMatrix(y)),
qslot = GET_SLOT(qr, install("q"));
CSP V = AS_CSP(GET_SLOT(qr, install("V"))),
R = AS_CSP(GET_SLOT(qr, install("R")));
int *ydims = INTEGER(GET_SLOT(ans, Matrix_DimSym)),
*q = INTEGER(qslot),
j, lq = LENGTH(qslot), m = R->m, n = R->n;
double *ax = REAL(GET_SLOT(ans, Matrix_xSym)),
*x = Alloca(m, double);
R_CheckStack();
R_CheckStack();
/* apply row permutation and multiply by Q' */
sparseQR_Qmult(V, REAL(GET_SLOT(qr, install("beta"))),
INTEGER(GET_SLOT(qr, Matrix_pSym)), 1,
REAL(GET_SLOT(ans, Matrix_xSym)), ydims);
for (j = 0; j < ydims[1]; j++) {
double *aj = ax + j * m;
cs_usolve(R, aj);
if (lq) {
cs_ipvec(q, aj, x, n);
Memcpy(aj, x, n);
}
}
UNPROTECT(1);
return ans;
}
SEXP sparseQR_resid_fitted(SEXP qr, SEXP y, SEXP resid)
{
SEXP ans = PROTECT(dup_mMatrix_as_dgeMatrix(y));
CSP V = AS_CSP(GET_SLOT(qr, install("V")));
int *ydims = INTEGER(GET_SLOT(ans, Matrix_DimSym)),
*p = INTEGER(GET_SLOT(qr, Matrix_pSym)),
i, j, m = V->m, n = V->n, res = asLogical(resid);
double *ax = REAL(GET_SLOT(ans, Matrix_xSym)),
*beta = REAL(GET_SLOT(qr, install("beta")));
R_CheckStack();
/* apply row permutation and multiply by Q' */
sparseQR_Qmult(V, beta, p, 1, ax, ydims);
for (j = 0; j < ydims[1]; j++) {
if (res) /* zero first n rows */
for (i = 0; i < n; i++) ax[i + j * m] = 0;
else /* zero last m - n rows */
for (i = n; i < m; i++) ax[i + j * m] = 0;
}
/* multiply by Q and apply inverse row permutation */
sparseQR_Qmult(V, beta, p, 0, ax, ydims);
UNPROTECT(1);
return ans;
}
SEXP dtCMatrix_sparse_solve(SEXP a, SEXP b)
{
SEXP ans = PROTECT(NEW_OBJECT(MAKE_CLASS("dgCMatrix")));
CSP A = AS_CSP(a), B = AS_CSP(b);
int *xp = INTEGER(ALLOC_SLOT(ans, Matrix_pSym, INTSXP, (B->n) + 1)),
xnz = 10 * B->p[B->n]; /* initial estimate of nnz in x */
int *ti = Calloc(xnz, int), k, lo = uplo_P(a)[0] == 'L', pos = 0;
double *tx = Calloc(xnz, double);
double *wrk = Alloca(A->n, double);
int *xi = Alloca(2*A->n, int); /* for cs_reach */
R_CheckStack();
if (A->m != A->n || B->n < 1 || A->n < 1 || A->n != B->m)
error(_("Dimensions of system to be solved are inconsistent"));
slot_dup(ans, b, Matrix_DimSym);
SET_DimNames(ans, b);
xp[0] = 0;
for (k = 0; k < B->n; k++) {
int top = cs_spsolve (A, B, k, xi, wrk, (int *)NULL, lo);
int nz = A->n - top, p;
xp[k + 1] = nz + xp[k];
if (xp[k + 1] > xnz) {
while (xp[k + 1] > xnz) xnz *= 2;
ti = Realloc(ti, xnz, int);
tx = Realloc(tx, xnz, double);
}
if (lo) /* increasing row order */
for(p = top; p < A->n; p++, pos++) {
ti[pos] = xi[p];
tx[pos] = wrk[xi[p]];
}
else /* decreasing order, reverse copy */
for(p = A->n - 1; p >= top; p--, pos++) {
ti[pos] = xi[p];
tx[pos] = wrk[xi[p]];
}
}
xnz = xp[B->n];
Memcpy(INTEGER(ALLOC_SLOT(ans, Matrix_iSym, INTSXP, xnz)), ti, xnz);
Memcpy( REAL(ALLOC_SLOT(ans, Matrix_xSym, REALSXP, xnz)), tx, xnz);
Free(ti); Free(tx);
UNPROTECT(1);
return ans;
}
SEXP sparseQR_validate(SEXP x)
{
CSP V = AS_CSP(GET_SLOT(x, install("V"))),
R = AS_CSP(GET_SLOT(x, install("R")));
SEXP beta = GET_SLOT(x, install("beta")),
p = GET_SLOT(x, Matrix_pSym),
q = GET_SLOT(x, install("q"));
int lq = LENGTH(q);
R_CheckStack();
if (LENGTH(p) != V->m)
return mkString(_("length(p) must match nrow(V)"));
if (LENGTH(beta) != V->m)
return mkString(_("length(beta) must match nrow(V)"));
if (lq && lq != R->n)
return mkString(_("length(q) must be zero or ncol(R)"));
if (V->n != R->n)
return mkString(_("ncol(V) != ncol(R)"));
/* FIXME: Check that the permutations are permutations */
return ScalarLogical(1);
}
SEXP sparseQR_qty(SEXP qr, SEXP y, SEXP trans)
{
SEXP ans = PROTECT(dup_mMatrix_as_dgeMatrix(y));
CSP V = AS_CSP(GET_SLOT(qr, install("V")));
R_CheckStack();
sparseQR_Qmult(V, REAL(GET_SLOT(qr, install("beta"))),
INTEGER(GET_SLOT(qr, Matrix_pSym)),
asLogical(trans),
REAL(GET_SLOT(ans, Matrix_xSym)),
INTEGER(GET_SLOT(ans, Matrix_DimSym)));
UNPROTECT(1);
return ans;
}
// called from package MatrixModels's R code
SEXP dgCMatrix_qrsol(SEXP x, SEXP y, SEXP ord)
{
/* FIXME: extend this to work in multivariate case, i.e. y a matrix with > 1 column ! */
SEXP ycp = PROTECT((TYPEOF(y) == REALSXP) ?
duplicate(y) : coerceVector(y, REALSXP));
CSP xc = AS_CSP(x); /* <--> x may be dgC* or dtC* */
int order = asInteger(ord);
#ifdef _not_yet_do_FIXME__
const char *nms[] = {"L", "coef", "Xty", "resid", ""};
SEXP ans = PROTECT(Rf_mkNamed(VECSXP, nms));
#endif
R_CheckStack();
if (order < 0 || order > 3)
error(_("dgCMatrix_qrsol(., order) needs order in {0,..,3}"));
/* --> cs_amd() --- order 0: natural, 1: Chol, 2: LU, 3: QR */
if (LENGTH(ycp) != xc->m)
error(_("Dimensions of system to be solved are inconsistent"));
/* FIXME? Note that qr_sol() would allow *under-determined systems;
* In general, we'd need LENGTH(ycp) = max(n,m)
* FIXME also: multivariate y (see above)
*/
if (xc->m < xc->n || xc->n <= 0)
error(_("dgCMatrix_qrsol(<%d x %d>-matrix) requires a 'tall' rectangular matrix"),
xc->m, xc->n);
/* cs_qrsol(): Tim Davis (2006) .. "8.2 Using a QR factorization", p.136f , calling
* ------- cs_sqr(order, ..), see p.76 */
/* MM: FIXME: write our *OWN* version of - the first case (m >= n) - of cs_qrsol()
* --------- which will (1) work with a *multivariate* y
* (2) compute coefficients properly, not overwriting RHS
*/
if (!cs_qrsol(order, xc, REAL(ycp)))
/* return value really is 0 or 1 - no more info there */
error(_("cs_qrsol() failed inside dgCMatrix_qrsol()"));
/* Solution is only in the first part of ycp -- cut its length back to n : */
ycp = lengthgets(ycp, (R_len_t) xc->n);
UNPROTECT(1);
return ycp;
}
SEXP dtCMatrix_matrix_solve(SEXP a, SEXP b, SEXP classed)
{
int cl = asLogical(classed);
SEXP ans = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix")));
CSP A = AS_CSP(a);
int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)),
*bdims = INTEGER(cl ? GET_SLOT(b, Matrix_DimSym) :
getAttrib(b, R_DimSymbol));
int j, n = bdims[0], nrhs = bdims[1], lo = (*uplo_P(a) == 'L');
double *bx;
R_CheckStack();
if (*adims != n || nrhs < 1 || *adims < 1 || *adims != adims[1])
error(_("Dimensions of system to be solved are inconsistent"));
Memcpy(INTEGER(ALLOC_SLOT(ans, Matrix_DimSym, INTSXP, 2)), bdims, 2);
/* FIXME: copy dimnames or Dimnames as well */
bx = Memcpy(REAL(ALLOC_SLOT(ans, Matrix_xSym, REALSXP, n * nrhs)),
REAL(cl ? GET_SLOT(b, Matrix_xSym):b), n * nrhs);
for (j = 0; j < nrhs; j++)
lo ? cs_lsolve(A, bx + n * j) : cs_usolve(A, bx + n * j);
UNPROTECT(1);
return ans;
}
