SEXP dgeMatrix_crossprod(SEXP x, SEXP trans)
{
int tr = asLogical(trans);/* trans=TRUE: tcrossprod(x) */
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dpoMatrix"))),
nms = VECTOR_ELT(GET_SLOT(x, Matrix_DimNamesSym), tr ? 0 : 1),
vDnms = ALLOC_SLOT(val, Matrix_DimNamesSym, VECSXP, 2);
int *Dims = INTEGER(GET_SLOT(x, Matrix_DimSym)),
*vDims = INTEGER(ALLOC_SLOT(val, Matrix_DimSym, INTSXP, 2));
int k = tr ? Dims[1] : Dims[0], n = tr ? Dims[0] : Dims[1];
double *vx = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, n * n)),
one = 1.0, zero = 0.0;
AZERO(vx, n * n);
SET_SLOT(val, Matrix_uploSym, mkString("U"));
ALLOC_SLOT(val, Matrix_factorSym, VECSXP, 0);
vDims[0] = vDims[1] = n;
SET_VECTOR_ELT(vDnms, 0, duplicate(nms));
SET_VECTOR_ELT(vDnms, 1, duplicate(nms));
F77_CALL(dsyrk)("U", tr ? "N" : "T", &n, &k,
&one, REAL(GET_SLOT(x, Matrix_xSym)), Dims,
&zero, vx, &n);
SET_SLOT(val, Matrix_factorSym, allocVector(VECSXP, 0));
UNPROTECT(1);
return val;
}
/**
* Copy the contents of N to a csn_LU or csn_QR object and,
* optionally, free N or free both N and the pointers to its contents.
*
* @param a csn object to be converted
* @param cl the name of the S4 class of the object to be generated
* @param dofree 0 - don't free a; > 0 cs_free a; < 0 Free a
*
* @return SEXP containing a copy of S
*/
SEXP Matrix_csn_to_SEXP(csn *N, char *cl, int dofree)
{
SEXP ans;
char *valid[] = {"csn_LU", "csn_QR", ""};
int ctype = Matrix_check_class(cl, valid), n = (N->U)->n;
if (ctype < 0)
error("Inappropriate class '%s' for Matrix_csn_to_SEXP", cl);
ans = PROTECT(NEW_OBJECT(MAKE_CLASS(cl)));
/* allocate and copy common slots */
/* FIXME: Use the triangular matrix classes for csn_LU */
SET_SLOT(ans, install("L"), /* these are free'd later if requested */
Matrix_cs_to_SEXP(N->L, "dgCMatrix", 0));
SET_SLOT(ans, install("U"),
Matrix_cs_to_SEXP(N->U, "dgCMatrix", 0));
switch(ctype) {
case 0:
Memcpy(INTEGER(ALLOC_SLOT(ans, install("Pinv"), INTSXP, n)),
N->pinv, n);
break;
case 1:
Memcpy(REAL(ALLOC_SLOT(ans, install("beta"), REALSXP, n)),
N->B, n);
break;
default:
error("Inappropriate class '%s' for Matrix_csn_to_SEXP", cl);
}
if (dofree > 0) cs_nfree(N);
if (dofree < 0) {
Free(N->L); Free(N->U); Free(N);
}
UNPROTECT(1);
return ans;
}
SEXP csc_matrix_crossprod(SEXP x, SEXP y, SEXP classed)
{
int cl = asLogical(classed);
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix")));
int *xdims = INTEGER(GET_SLOT(x, Matrix_DimSym)),
*ydims = INTEGER(cl ? GET_SLOT(y, Matrix_DimSym) :
getAttrib(y, R_DimSymbol)),
*vdims = INTEGER(ALLOC_SLOT(val, Matrix_DimSym, INTSXP, 2));
int *xi = INTEGER(GET_SLOT(x, Matrix_iSym)),
*xp = INTEGER(GET_SLOT(x, Matrix_pSym));
int j, k = xdims[0], m = xdims[1], n = ydims[1];
double *vx, *xx = REAL(GET_SLOT(x, Matrix_xSym)),
*yx = REAL(cl ? GET_SLOT(y, Matrix_xSym) : y);
if (!cl && !(isMatrix(y) && isReal(y)))
error(_("y must be a numeric matrix"));
if (ydims[0] != k)
error(_("x and y must have the same number of rows"));
if (m < 1 || n < 1 || k < 1)
error(_("Matrices with zero extents cannot be multiplied"));
vdims[0] = m; vdims[1] = n;
vx = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, m * n));
for (j = 0; j < n; j++) {
int i; double *ypt = yx + j * k;
for(i = 0; i < m; i++) {
int ii; double accum = 0.;
for (ii = xp[i]; ii < xp[i+1]; ii++) {
accum += xx[ii] * ypt[xi[ii]];
}
vx[i + j * m] = accum;
}
}
UNPROTECT(1);
return val;
}
/**
* Copy the contents of a to an appropriate CsparseMatrix object and,
* optionally, free a or free both a and the pointers to its contents.
*
* @param a matrix to be converted
* @param cl the name of the S4 class of the object to be generated
* @param dofree 0 - don't free a; > 0 cs_free a; < 0 Free a
*
* @return SEXP containing a copy of a
*/
SEXP Matrix_cs_to_SEXP(cs *a, char *cl, int dofree)
{
SEXP ans;
char *valid[] = {"dgCMatrix", "dsCMatrix", "dtCMatrix", ""};
int *dims, ctype = Matrix_check_class(cl, valid), nz;
if (ctype < 0)
error("invalid class of object to Matrix_cs_to_SEXP");
ans = PROTECT(NEW_OBJECT(MAKE_CLASS(cl)));
/* allocate and copy common slots */
dims = INTEGER(ALLOC_SLOT(ans, Matrix_DimSym, INTSXP, 2));
dims[0] = a->m; dims[1] = a->n;
Memcpy(INTEGER(ALLOC_SLOT(ans, Matrix_pSym, INTSXP, a->n + 1)),
a->p, a->n + 1);
nz = a->p[a->n];
Memcpy(INTEGER(ALLOC_SLOT(ans, Matrix_iSym, INTSXP, nz)), a->i, nz);
Memcpy(REAL(ALLOC_SLOT(ans, Matrix_xSym, REALSXP, nz)), a->x, nz);
if (ctype > 0) {
int uplo = is_sym(a);
if (!uplo) error("cs matrix not compatible with class");
SET_SLOT(ans, Matrix_diagSym, mkString("N"));
SET_SLOT(ans, Matrix_uploSym, mkString(uplo < 0 ? "L" : "U"));
}
if (dofree > 0) cs_spfree(a);
if (dofree < 0) Free(a);
UNPROTECT(1);
return ans;
}
/**
* Copy the contents of S to a css_LU or css_QR object and,
* optionally, free S or free both S and the pointers to its contents.
*
* @param a css object to be converted
* @param cl the name of the S4 class of the object to be generated
* @param dofree 0 - don't free a; > 0 cs_free a; < 0 Free a
* @param m number of rows in original matrix
* @param n number of columns in original matrix
*
* @return SEXP containing a copy of S
*/
SEXP Matrix_css_to_SEXP(css *S, char *cl, int dofree, int m, int n)
{
SEXP ans;
char *valid[] = {"css_LU", "css_QR", ""};
int *nz, ctype = Matrix_check_class(cl, valid);
if (ctype < 0)
error("Inappropriate class '%s' for Matrix_css_to_SEXP", cl);
ans = PROTECT(NEW_OBJECT(MAKE_CLASS(cl)));
/* allocate and copy common slots */
Memcpy(INTEGER(ALLOC_SLOT(ans, install("Q"), INTSXP, n)), S->q, n);
nz = INTEGER(ALLOC_SLOT(ans, install("nz"), INTSXP, 3));
nz[0] = S->m2; nz[1] = S->lnz; nz[2] = S->unz;
switch(ctype) {
case 0:
break;
case 1:
Memcpy(INTEGER(ALLOC_SLOT(ans, install("Pinv"), INTSXP, m)),
S->pinv, m);
Memcpy(INTEGER(ALLOC_SLOT(ans, install("parent"), INTSXP, n)),
S->parent, n);
Memcpy(INTEGER(ALLOC_SLOT(ans, install("cp"), INTSXP, n)),
S->cp, n);
break;
default:
error("Inappropriate class '%s' for Matrix_css_to_SEXP", cl);
}
if (dofree > 0) cs_sfree(S);
if (dofree < 0) Free(S);
UNPROTECT(1);
return ans;
}
SEXP dtTMatrix_as_dtCMatrix(SEXP x)
{
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dtCMatrix"))),
dimP = GET_SLOT(x, Matrix_DimSym),
xiP = GET_SLOT(x, Matrix_iSym);
int n = INTEGER(dimP)[0],
nnz = length(xiP);
int *ti = Calloc(nnz, int),
*vp = INTEGER(ALLOC_SLOT(val, Matrix_pSym, INTSXP, n + 1));
double *tx = Calloc(nnz, double);
SET_SLOT(val, Matrix_DimSym, duplicate(dimP));
SET_SLOT(val, Matrix_uploSym, duplicate(GET_SLOT(x, Matrix_uploSym)));
SET_SLOT(val, Matrix_diagSym, duplicate(GET_SLOT(x, Matrix_diagSym)));
triplet_to_col(n, n, nnz, INTEGER(xiP),
INTEGER(GET_SLOT(x, Matrix_jSym)),
REAL(GET_SLOT(x, Matrix_xSym)),
vp, ti, tx);
nnz = vp[n];
Memcpy(INTEGER(ALLOC_SLOT(val, Matrix_iSym, INTSXP, nnz)), ti, nnz);
Memcpy( REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, nnz)), tx, nnz);
Free(ti); Free(tx);
UNPROTECT(1);
return val;
}
SEXP dsyMatrix_trf(SEXP x)
{
SEXP val = get_factors(x, "BunchKaufman"),
dimP = GET_SLOT(x, Matrix_DimSym),
uploP = GET_SLOT(x, Matrix_uploSym);
int *dims = INTEGER(dimP), *perm, info;
int lwork = -1, n = dims[0];
const char *uplo = CHAR(STRING_ELT(uploP, 0));
double tmp, *vx, *work;
if (val != R_NilValue) return val;
dims = INTEGER(dimP);
val = PROTECT(NEW_OBJECT_OF_CLASS("BunchKaufman"));
SET_SLOT(val, Matrix_uploSym, duplicate(uploP));
SET_SLOT(val, Matrix_diagSym, mkString("N"));
SET_SLOT(val, Matrix_DimSym, duplicate(dimP));
vx = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, n * n));
AZERO(vx, n * n);
F77_CALL(dlacpy)(uplo, &n, &n, REAL(GET_SLOT(x, Matrix_xSym)), &n, vx, &n);
perm = INTEGER(ALLOC_SLOT(val, Matrix_permSym, INTSXP, n));
F77_CALL(dsytrf)(uplo, &n, vx, &n, perm, &tmp, &lwork, &info);
lwork = (int) tmp;
C_or_Alloca_TO(work, lwork, double);
F77_CALL(dsytrf)(uplo, &n, vx, &n, perm, work, &lwork, &info);
if(lwork >= SMALL_4_Alloca) Free(work);
if (info) error(_("Lapack routine dsytrf returned error code %d"), info);
UNPROTECT(1);
return set_factors(x, val, "BunchKaufman");
}
/* 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");
}
SEXP graphNEL_as_dgTMatrix(SEXP x, SEXP symmetric)
{
int sym = asLogical(symmetric);
SEXP nodes = GET_SLOT(x, install("nodes")),
edgeL = GET_SLOT(x, install("edgeL")),
ans = PROTECT(NEW_OBJECT(MAKE_CLASS(sym
? "dsTMatrix"
: "dgTMatrix")));
int *ii, *jj, *dims, i, j, nnd = LENGTH(nodes), pos, totl;
double *xx;
totl = 0;
for (i = 0; i < nnd; i++)
totl += LENGTH(Matrix_getElement(VECTOR_ELT(edgeL, i), "edges"));
dims = INTEGER(ALLOC_SLOT(ans, Matrix_DimSym, INTSXP, 2));
dims[0] = dims[1] = nnd;
if (isString(nodes)) {
SEXP dnms = ALLOC_SLOT(ans, Matrix_DimNamesSym, VECSXP, 2);
SET_VECTOR_ELT(dnms, 0, duplicate(nodes));
SET_VECTOR_ELT(dnms, 1, duplicate(nodes));
}
ii = Calloc(totl, int);
jj = Calloc(totl, int);
xx = Calloc(totl, double);
pos = 0;
for (i = 0; i < nnd; i++) {
SEXP edg = VECTOR_ELT(edgeL, i);
SEXP edges = Matrix_getElement(edg, "edges"),
weights = Matrix_getElement(edg, "weights");
int *edgs = INTEGER(PROTECT(coerceVector(edges, INTSXP))),
nedg = LENGTH(edges);
double *wts = REAL(weights);
for (j = 0; j < nedg; j++) {
int j1 = edgs[j] - 1;
/* symmetric case stores upper triangle only */
if ((!sym) || i <= j1) {
ii[pos] = i;
jj[pos] = j1;
xx[pos] = wts[j];
pos++;
}
}
UNPROTECT(1);
}
Memcpy(INTEGER(ALLOC_SLOT(ans, Matrix_iSym, INTSXP, pos)), ii, pos);
Memcpy(INTEGER(ALLOC_SLOT(ans, Matrix_jSym, INTSXP, pos)), jj, pos);
Memcpy(REAL(ALLOC_SLOT(ans, Matrix_xSym, REALSXP, pos)), xx, pos);
Free(ii); Free(jj); Free(xx);
UNPROTECT(1);
return ans;
}
SEXP csc_matrix_mm(SEXP a, SEXP b, SEXP classed, SEXP right)
{
int cl = asLogical(classed), rt = asLogical(right);
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix")));
int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)),
*ai = INTEGER(GET_SLOT(a, Matrix_iSym)),
*ap = INTEGER(GET_SLOT(a, Matrix_pSym)),
*bdims = INTEGER(cl ? GET_SLOT(b, Matrix_DimSym) :
getAttrib(b, R_DimSymbol)),
*cdims = INTEGER(ALLOC_SLOT(val, Matrix_DimSym, INTSXP, 2)),
chk, ione = 1, j, jj, k, m, n;
double *ax = REAL(GET_SLOT(a, Matrix_xSym)),
*bx = REAL(cl ? GET_SLOT(b, Matrix_xSym) : b), *cx;
if (rt) {
m = bdims[0]; n = adims[1]; k = bdims[1]; chk = adims[0];
} else {
m = adims[0]; n = bdims[1]; k = adims[1]; chk = bdims[0];
}
if (chk != k)
error(_("Matrices are not conformable for multiplication"));
if (m < 1 || n < 1 || k < 1)
error(_("Matrices with zero extents cannot be multiplied"));
cx = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, m * n));
AZERO(cx, m * n); /* zero the accumulators */
for (j = 0; j < n; j++) { /* across columns of c */
if (rt) {
int kk, k2 = ap[j + 1];
for (kk = ap[j]; kk < k2; kk++) {
F77_CALL(daxpy)(&m, &ax[kk], &bx[ai[kk]*m],
&ione, &cx[j*m], &ione);
}
} else {
double *ccol = cx + j * m,
*bcol = bx + j * k;
for (jj = 0; jj < k; jj++) { /* across columns of a */
int kk, k2 = ap[jj + 1];
for (kk = ap[jj]; kk < k2; kk++) {
ccol[ai[kk]] += ax[kk] * bcol[jj];
}
}
}
}
cdims[0] = m; cdims[1] = n;
UNPROTECT(1);
return val;
}
SEXP dgeMatrix_LU_(SEXP x, Rboolean warn_sing)
{
SEXP val = get_factors(x, "LU");
int *dims, npiv, info;
if (val != R_NilValue) /* nothing to do if it's there in 'factors' slot */
return val;
dims = INTEGER(GET_SLOT(x, Matrix_DimSym));
if (dims[0] < 1 || dims[1] < 1)
error(_("Cannot factor a matrix with zero extents"));
npiv = (dims[0] <dims[1]) ? dims[0] : dims[1];
val = PROTECT(NEW_OBJECT(MAKE_CLASS("denseLU")));
slot_dup(val, x, Matrix_xSym);
slot_dup(val, x, Matrix_DimSym);
F77_CALL(dgetrf)(dims, dims + 1, REAL(GET_SLOT(val, Matrix_xSym)),
dims,
INTEGER(ALLOC_SLOT(val, Matrix_permSym, INTSXP, npiv)),
&info);
if (info < 0)
error(_("Lapack routine %s returned error code %d"), "dgetrf", info);
else if (info > 0 && warn_sing)
warning(_("Exact singularity detected during LU decomposition."));
UNPROTECT(1);
return set_factors(x, val, "LU");
}
SEXP dpoMatrix_chol(SEXP x)
{
SEXP val = get_factors(x, "Cholesky"),
dimP = GET_SLOT(x, Matrix_DimSym),
uploP = GET_SLOT(x, Matrix_uploSym);
char *uplo = CHAR(STRING_ELT(uploP, 0));
int *dims = INTEGER(dimP), info;
int n = dims[0];
double *vx;
if (val != R_NilValue) return val;
dims = INTEGER(dimP);
val = PROTECT(NEW_OBJECT(MAKE_CLASS("Cholesky")));
SET_SLOT(val, Matrix_uploSym, duplicate(uploP));
SET_SLOT(val, Matrix_diagSym, mkString("N"));
SET_SLOT(val, Matrix_DimSym, duplicate(dimP));
vx = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, n * n));
AZERO(vx, n * n);
F77_CALL(dlacpy)(uplo, &n, &n, REAL(GET_SLOT(x, Matrix_xSym)), &n, vx, &n);
if (n > 0) {
F77_CALL(dpotrf)(uplo, &n, vx, &n, &info);
if (info) {
if(info > 0)
error(_("the leading minor of order %d is not positive definite"),
info);
else /* should never happen! */
error(_("Lapack routine %s returned error code %d"), "dpotrf", info);
}
}
UNPROTECT(1);
return set_factors(x, val, "Cholesky");
}
// 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;
}
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;
}
// n.CMatrix --> [dli].CMatrix (not going through CHM!)
SEXP nz2Csparse(SEXP x, enum x_slot_kind r_kind)
{
const char *cl_x = class_P(x);
if(cl_x[0] != 'n') error(_("not a 'n.CMatrix'"));
if(cl_x[2] != 'C') error(_("not a CsparseMatrix"));
int nnz = LENGTH(GET_SLOT(x, Matrix_iSym));
SEXP ans;
char *ncl = strdup(cl_x);
double *dx_x; int *ix_x;
ncl[0] = (r_kind == x_double ? 'd' :
(r_kind == x_logical ? 'l' :
/* else (for now): r_kind == x_integer : */ 'i'));
PROTECT(ans = NEW_OBJECT(MAKE_CLASS(ncl)));
// create a correct 'x' slot:
switch(r_kind) {
int i;
case x_double: // 'd'
dx_x = REAL(ALLOC_SLOT(ans, Matrix_xSym, REALSXP, nnz));
for (i=0; i < nnz; i++) dx_x[i] = 1.;
break;
case x_logical: // 'l'
ix_x = LOGICAL(ALLOC_SLOT(ans, Matrix_xSym, LGLSXP, nnz));
for (i=0; i < nnz; i++) ix_x[i] = TRUE;
break;
case x_integer: // 'i'
ix_x = INTEGER(ALLOC_SLOT(ans, Matrix_xSym, INTSXP, nnz));
for (i=0; i < nnz; i++) ix_x[i] = 1;
break;
default:
error(_("nz2Csparse(): invalid/non-implemented r_kind = %d"),
r_kind);
}
// now copy all other slots :
slot_dup(ans, x, Matrix_iSym);
slot_dup(ans, x, Matrix_pSym);
slot_dup(ans, x, Matrix_DimSym);
slot_dup(ans, x, Matrix_DimNamesSym);
if(ncl[1] != 'g') { // symmetric or triangular ...
slot_dup_if_has(ans, x, Matrix_uploSym);
slot_dup_if_has(ans, x, Matrix_diagSym);
}
UNPROTECT(1);
return ans;
}
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;
}
SEXP tsc_transpose(SEXP x)
{
SEXP ans = PROTECT(NEW_OBJECT(MAKE_CLASS("dtCMatrix"))),
islot = GET_SLOT(x, Matrix_iSym);
int nnz = length(islot),
*adims, *xdims = INTEGER(GET_SLOT(x, Matrix_DimSym));
int up = uplo_P(x)[0] == 'U';
adims = INTEGER(ALLOC_SLOT(ans, Matrix_DimSym, INTSXP, 2));
adims[0] = xdims[1]; adims[1] = xdims[0];
if(*diag_P(x) == 'U')
SET_SLOT(ans, Matrix_diagSym, duplicate(GET_SLOT(x, Matrix_diagSym)));
SET_SLOT(ans, Matrix_uploSym, mkString(up ? "L" : "U"));
csc_compTr(xdims[0], xdims[1], nnz,
INTEGER(GET_SLOT(x, Matrix_pSym)), INTEGER(islot),
REAL(GET_SLOT(x, Matrix_xSym)),
INTEGER(ALLOC_SLOT(ans, Matrix_pSym, INTSXP, xdims[0] + 1)),
INTEGER(ALLOC_SLOT(ans, Matrix_iSym, INTSXP, nnz)),
REAL(ALLOC_SLOT(ans, Matrix_xSym, REALSXP, nnz)));
UNPROTECT(1);
return ans;
}
/* this is very close to dsyMatrix_as_dsp* () in ./dsyMatrix.c : */
SEXP lsyMatrix_as_lspMatrix(SEXP from)
{
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("lspMatrix"))),
uplo = GET_SLOT(from, Matrix_uploSym),
dimP = GET_SLOT(from, Matrix_DimSym);
int n = *INTEGER(dimP);
SET_SLOT(val, Matrix_DimSym, duplicate(dimP));
SET_SLOT(val, Matrix_uploSym, duplicate(uplo));
full_to_packed_int(
LOGICAL(ALLOC_SLOT(val, Matrix_xSym, LGLSXP, (n*(n+1))/2)),
LOGICAL( GET_SLOT(from, Matrix_xSym)), n,
*CHAR(STRING_ELT(uplo, 0)) == 'U' ? UPP : LOW, NUN);
UNPROTECT(1);
return val;
}
SEXP LU_expand(SEXP x)
{
char *nms[] = {"L", "U", "P", ""};
SEXP L, U, P, val = PROTECT(Matrix_make_named(VECSXP, nms)),
lux = GET_SLOT(x, Matrix_xSym),
dd = GET_SLOT(x, Matrix_DimSym);
int *iperm, *perm, *pivot = INTEGER(GET_SLOT(x, Matrix_permSym)),
i, n = INTEGER(dd)[0];
SET_VECTOR_ELT(val, 0, NEW_OBJECT(MAKE_CLASS("dtrMatrix")));
L = VECTOR_ELT(val, 0);
SET_VECTOR_ELT(val, 1, NEW_OBJECT(MAKE_CLASS("dtrMatrix")));
U = VECTOR_ELT(val, 1);
SET_VECTOR_ELT(val, 2, NEW_OBJECT(MAKE_CLASS("pMatrix")));
P = VECTOR_ELT(val, 2);
SET_SLOT(L, Matrix_xSym, duplicate(lux));
SET_SLOT(L, Matrix_DimSym, duplicate(dd));
SET_SLOT(L, Matrix_uploSym, mkString("L"));
SET_SLOT(L, Matrix_diagSym, mkString("U"));
make_d_matrix_triangular(REAL(GET_SLOT(L, Matrix_xSym)), L);
SET_SLOT(U, Matrix_xSym, duplicate(lux));
SET_SLOT(U, Matrix_DimSym, duplicate(dd));
SET_SLOT(U, Matrix_uploSym, mkString("U"));
SET_SLOT(U, Matrix_diagSym, mkString("N"));
make_d_matrix_triangular(REAL(GET_SLOT(U, Matrix_xSym)), U);
SET_SLOT(P, Matrix_DimSym, duplicate(dd));
iperm = Calloc(n, int);
perm = INTEGER(ALLOC_SLOT(P, Matrix_permSym, INTSXP, n));
for (i = 0; i < n; i++) iperm[i] = i + 1; /* initialize permutation*/
for (i = 0; i < n; i++) { /* generate inverse permutation */
int newpos = pivot[i] - 1;
if (newpos != i) {
int tmp = iperm[i];
iperm[i] = iperm[newpos];
iperm[newpos] = tmp;
}
}
/* invert the inverse */
for (i = 0; i < n; i++) perm[iperm[i] - 1] = i + 1;
Free(iperm);
UNPROTECT(1);
return val;
}
SEXP compressed_to_dgTMatrix(SEXP x, SEXP colP)
{
int col = asLogical(colP); /* 1 if "C"olumn compressed; 0 if "R"ow */
SEXP indSym = col ? Matrix_iSym : Matrix_jSym;
SEXP ans = PROTECT(NEW_OBJECT(MAKE_CLASS("dgTMatrix"))),
indP = GET_SLOT(x, indSym),
pP = GET_SLOT(x, Matrix_pSym);
int npt = length(pP) - 1;
SET_SLOT(ans, Matrix_DimSym, duplicate(GET_SLOT(x, Matrix_DimSym)));
SET_SLOT(ans, Matrix_xSym, duplicate(GET_SLOT(x, Matrix_xSym)));
SET_SLOT(ans, indSym, duplicate(indP));
expand_cmprPt(npt, INTEGER(pP),
INTEGER(ALLOC_SLOT(ans, col ? Matrix_jSym : Matrix_iSym,
INTSXP, length(indP))));
UNPROTECT(1);
return ans;
}
SEXP dtTMatrix_as_dtrMatrix(SEXP x)
{
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dtrMatrix"))),
dimP = GET_SLOT(x, Matrix_DimSym),
xiP = GET_SLOT(x, Matrix_iSym);
int k, m = INTEGER(dimP)[0], n = INTEGER(dimP)[1], nnz = length(xiP);
int *xi = INTEGER(xiP), *xj = INTEGER(GET_SLOT(x, Matrix_jSym)),
sz = m * n;
double *tx = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, sz)),
*xx = REAL(GET_SLOT(x, Matrix_xSym));
SET_SLOT(val, Matrix_DimSym, duplicate(dimP));
SET_SLOT(val, Matrix_uploSym, duplicate(GET_SLOT(x, Matrix_uploSym)));
SET_SLOT(val, Matrix_diagSym, duplicate(GET_SLOT(x, Matrix_diagSym)));
AZERO(tx, sz);
for (k = 0; k < nnz; k++) tx[xi[k] + xj[k] * m] = xx[k];
UNPROTECT(1);
return val;
}
SEXP dtrMatrix_as_dtpMatrix(SEXP from)
{
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dtpMatrix"))),
uplo = GET_SLOT(from, Matrix_uploSym),
diag = GET_SLOT(from, Matrix_diagSym),
dimP = GET_SLOT(from, Matrix_DimSym);
int n = *INTEGER(dimP);
SET_SLOT(val, Matrix_DimSym, duplicate(dimP));
SET_SLOT(val, Matrix_diagSym, duplicate(diag));
SET_SLOT(val, Matrix_uploSym, duplicate(uplo));
full_to_packed_double(
REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, (n*(n+1))/2)),
REAL(GET_SLOT(from, Matrix_xSym)), n,
*CHAR(STRING_ELT(uplo, 0)) == 'U' ? UPP : LOW,
*CHAR(STRING_ELT(diag, 0)) == 'U' ? UNT : NUN);
UNPROTECT(1);
return val;
}
/* this is very close to dtpMatrix_as_dtr* () in ./dtpMatrix.c : */
SEXP ltpMatrix_as_ltrMatrix(SEXP from)
{
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("ltrMatrix"))),
uplo = GET_SLOT(from, Matrix_uploSym),
diag = GET_SLOT(from, Matrix_diagSym),
dimP = GET_SLOT(from, Matrix_DimSym),
dmnP = GET_SLOT(from, Matrix_DimNamesSym);
int n = *INTEGER(dimP);
SET_SLOT(val, Matrix_DimSym, duplicate(dimP));
SET_SLOT(val, Matrix_DimNamesSym, duplicate(dmnP));
SET_SLOT(val, Matrix_diagSym, duplicate(diag));
SET_SLOT(val, Matrix_uploSym, duplicate(uplo));
packed_to_full_int(LOGICAL(ALLOC_SLOT(val, Matrix_xSym, LGLSXP, n*n)),
LOGICAL(GET_SLOT(from, Matrix_xSym)), n,
*CHAR(STRING_ELT(uplo, 0)) == 'U' ? UPP : LOW);
UNPROTECT(1);
return val;
}
// this is very close to lsyMatrix_as_lsp*() in ./ldense.c -- keep synced !
SEXP dsyMatrix_as_dspMatrix(SEXP from)
{
SEXP val = PROTECT(NEW_OBJECT_OF_CLASS("dspMatrix")),
uplo = GET_SLOT(from, Matrix_uploSym),
dimP = GET_SLOT(from, Matrix_DimSym);
int n = *INTEGER(dimP);
SET_SLOT(val, Matrix_DimSym, duplicate(dimP));
SET_SLOT(val, Matrix_uploSym, duplicate(uplo));
full_to_packed_double(
REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, (n*(n+1))/2)),
REAL( GET_SLOT(from, Matrix_xSym)), n,
*CHAR(STRING_ELT(uplo, 0)) == 'U' ? UPP : LOW, NUN);
SET_SLOT(val, Matrix_DimNamesSym,
duplicate(GET_SLOT(from, Matrix_DimNamesSym)));
SET_SLOT(val, Matrix_factorSym,
duplicate(GET_SLOT(from, Matrix_factorSym)));
UNPROTECT(1);
return val;
}
SEXP R_to_CMatrix(SEXP x)
{
SEXP ans, tri = PROTECT(allocVector(LGLSXP, 1));
char *ncl = strdup(class_P(x));
static const char *valid[] = { MATRIX_VALID_Rsparse, ""};
int ctype = R_check_class_etc(x, valid);
int *x_dims = INTEGER(GET_SLOT(x, Matrix_DimSym)), *a_dims;
PROTECT_INDEX ipx;
if (ctype < 0)
error(_("invalid class(x) '%s' in R_to_CMatrix(x)"), ncl);
/* replace 'R' with 'C' : */
ncl[2] = 'C';
PROTECT_WITH_INDEX(ans = NEW_OBJECT(MAKE_CLASS(ncl)), &ipx);
a_dims = INTEGER(ALLOC_SLOT(ans, Matrix_DimSym, INTSXP, 2));
/* reversed dim() since we will transpose: */
a_dims[0] = x_dims[1];
a_dims[1] = x_dims[0];
/* triangular: */ LOGICAL(tri)[0] = 0;
if((ctype / 3) != 2) /* not n..Matrix */
slot_dup(ans, x, Matrix_xSym);
if(ctype % 3) { /* s(ymmetric) or t(riangular) : */
SET_SLOT(ans, Matrix_uploSym,
mkString((*uplo_P(x) == 'U') ? "L" : "U"));
if(ctype % 3 == 2) { /* t(riangular) : */
LOGICAL(tri)[0] = 1;
slot_dup(ans, x, Matrix_diagSym);
}
}
SET_SLOT(ans, Matrix_iSym, duplicate(GET_SLOT(x, Matrix_jSym)));
slot_dup(ans, x, Matrix_pSym);
REPROTECT(ans = Csparse_transpose(ans, tri), ipx);
SET_DimNames(ans, x);
// possibly asymmetric for symmetricMatrix is ok
free(ncl);
UNPROTECT(2);
return ans;
}
/* This does *not* work: gives *empty* .Data slot [bug in NEW_OBJECT()? ] */
SEXP d2mpfr(SEXP x, SEXP prec)
{
int i_prec = asInteger(prec),
nx = LENGTH(x), np = LENGTH(prec),
n = (nx == 0 || np == 0) ? 0 : imax2(nx, np),
nprot = 1;
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("mpfr"))),
lis = ALLOC_SLOT(val, Rmpfr_Data_Sym, VECSXP, n);
double *dx;
if(!isReal(x)) { PROTECT(x = coerceVector(x, REALSXP)); nprot++; }
REprintf("d2mpfr(x, prec): length(x) = %d, prec = %d -> length(lis) = %d\n",
nx, i_prec, LENGTH(lis));
dx = REAL(x);
for(int i = 0; i < n; i++) {
SET_VECTOR_ELT(lis, i, duplicate(d2mpfr1_(dx [i % nx],
i_prec [i % np])));
}
UNPROTECT(nprot);
return val;
}
/* This and the following R_to_CMatrix() lead to memory-not-mapped seg.faults
* only with {32bit + R-devel + enable-R-shlib} -- no idea why */
SEXP compressed_to_TMatrix(SEXP x, SEXP colP)
{
int col = asLogical(colP); /* 1 if "C"olumn compressed; 0 if "R"ow */
/* however, for Csparse, we now effectively use the cholmod-based
* Csparse_to_Tsparse() in ./Csparse.c ; maybe should simply write
* an as_cholmod_Rsparse() function and then do "as there" ...*/
SEXP indSym = col ? Matrix_iSym : Matrix_jSym,
ans, indP = GET_SLOT(x, indSym),
pP = GET_SLOT(x, Matrix_pSym);
int npt = length(pP) - 1;
char *ncl = strdup(class_P(x));
static const char *valid[] = { MATRIX_VALID_Csparse, MATRIX_VALID_Rsparse, ""};
int ctype = R_check_class_etc(x, valid);
if (ctype < 0)
error(_("invalid class(x) '%s' in compressed_to_TMatrix(x)"), ncl);
/* replace 'C' or 'R' with 'T' :*/
ncl[2] = 'T';
ans = PROTECT(NEW_OBJECT(MAKE_CLASS(ncl)));
slot_dup(ans, x, Matrix_DimSym);
if((ctype / 3) % 4 != 2) /* not n..Matrix */
slot_dup(ans, x, Matrix_xSym);
if(ctype % 3) { /* s(ymmetric) or t(riangular) : */
slot_dup(ans, x, Matrix_uploSym);
if(ctype % 3 == 2) /* t(riangular) : */
slot_dup(ans, x, Matrix_diagSym);
}
SET_DimNames(ans, x);
// possibly asymmetric for symmetricMatrix is ok
SET_SLOT(ans, indSym, duplicate(indP));
expand_cmprPt(npt, INTEGER(pP),
INTEGER(ALLOC_SLOT(ans, col ? Matrix_jSym : Matrix_iSym,
INTSXP, length(indP))));
free(ncl);
UNPROTECT(1);
return ans;
}
SEXP dgeMatrix_matrix_mm(SEXP a, SEXP bP, SEXP right)
{
SEXP b = PROTECT(mMatrix_as_dgeMatrix(bP)),
val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix")));
int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)),
*bdims = INTEGER(GET_SLOT(b, Matrix_DimSym)),
*cdims = INTEGER(ALLOC_SLOT(val, Matrix_DimSym, INTSXP, 2));
double one = 1., zero = 0.;
if (asLogical(right)) {
int m = bdims[0], n = adims[1], k = bdims[1];
if (adims[0] != k)
error(_("Matrices are not conformable for multiplication"));
cdims[0] = m; cdims[1] = n;
if (m < 1 || n < 1 || k < 1) {
/* error(_("Matrices with zero extents cannot be multiplied")); */
ALLOC_SLOT(val, Matrix_xSym, REALSXP, m * n);
} else
F77_CALL(dgemm) ("N", "N", &m, &n, &k, &one,
REAL(GET_SLOT(b, Matrix_xSym)), &m,
REAL(GET_SLOT(a, Matrix_xSym)), &k, &zero,
REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, m * n)),
&m);
} else {
int m = adims[0], n = bdims[1], k = adims[1];
if (bdims[0] != k)
error(_("Matrices are not conformable for multiplication"));
cdims[0] = m; cdims[1] = n;
if (m < 1 || n < 1 || k < 1) {
/* error(_("Matrices with zero extents cannot be multiplied")); */
ALLOC_SLOT(val, Matrix_xSym, REALSXP, m * n);
} else
F77_CALL(dgemm)
("N", "N", &m, &n, &k, &one, REAL(GET_SLOT(a, Matrix_xSym)),
&m, REAL(GET_SLOT(b, Matrix_xSym)), &k, &zero,
REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, m * n)), &m);
}
ALLOC_SLOT(val, Matrix_DimNamesSym, VECSXP, 2);
UNPROTECT(2);
return val;
}
// returns a protected object
SEXP createTestRegression()
{
SEXP regression = PROTECT(regression = NEW_OBJECT(MAKE_CLASS("bmer")));
int protectCount = 0;
// create and setup the dims slot
int *dims = INTEGER(ALLOC_SLOT(regression, lme4_dimsSym, INTSXP, (int) (cvg_POS - nt_POS)));
dims[n_POS] = TEST_NUM_OBSERVATIONS;
dims[p_POS] = TEST_NUM_UNMODELED_COEFS;
dims[nt_POS] = TEST_NUM_FACTORS;
dims[isREML_POS] = FALSE;
dims[q_POS] = 0;
for (int i = 0; i < TEST_NUM_FACTORS; ++i) {
dims[q_POS] += testNumGroupsPerFactor[i] * testNumModeledCoefPerFactor[i];
}
dims[np_POS] = dims[q_POS];
int numObservations = dims[n_POS];
int numUnmodeledCoef = dims[p_POS];
int numModeledCoef = dims[q_POS];
int numFactors = dims[nt_POS];
// create the deviance slot
ALLOC_SLOT(regression, lme4_devianceSym, REALSXP, (int) (NULLdev_POS - ML_POS));
// create and setup the Gp slot
int *sparseRowsForFactor = INTEGER(ALLOC_SLOT(regression, lme4_GpSym, INTSXP, numFactors + 1));
sparseRowsForFactor[0] = 0;
for (int i = 0; i < numFactors; ++i) {
sparseRowsForFactor[i + 1] = testNumGroupsPerFactor[i] * testNumModeledCoefPerFactor[i] + sparseRowsForFactor[i];
}
// create and setup the X slot
SEXP denseDesignMatrixExp = ALLOC_SLOT(regression, lme4_XSym, REALSXP, numObservations * numUnmodeledCoef);
SET_DIMS(denseDesignMatrixExp, numObservations, numUnmodeledCoef);
double *denseDesignMatrix = REAL(denseDesignMatrixExp);
for (int i = 0; i < numObservations; ++i) {
denseDesignMatrix[i] = 1.0;
denseDesignMatrix[i + numObservations] = testDenseDesignMatrixColumn2[i];
denseDesignMatrix[i + 2 * numObservations] = testDenseDesignMatrixColumn3[i];
}
double *response = REAL(ALLOC_SLOT(regression, lme4_ySym, REALSXP, numObservations));
Memcpy(response, testResponse, numObservations);
// sXwt slot
double *sqrtObservationWeights = REAL(ALLOC_SLOT(regression, lme4_sqrtXWtSym, REALSXP, numObservations));
for (int i = 0; i < numObservations; ++i) sqrtObservationWeights[i] = sqrt(testObservationWeights[i]);
// create and setup the Zt slot
SEXP sparseDesignMatrixExp = PROTECT(sparseDesignMatrixExp = NEW_OBJECT(MAKE_CLASS("dgCMatrix")));
++protectCount;
SET_SLOT(regression, lme4_ZtSym, sparseDesignMatrixExp);
int *sdm_dims = INTEGER(ALLOC_SLOT(sparseDesignMatrixExp, install("Dim"), INTSXP, 2));
sdm_dims[0] = numModeledCoef;
sdm_dims[1] = numObservations;
int numSparseNonZeroes = 0;
for (int i = 0; i < numFactors; ++i) numSparseNonZeroes += testNumModeledCoefPerFactor[i];
numSparseNonZeroes *= numObservations;
int *sdm_nonZeroRowIndices = INTEGER(ALLOC_SLOT(sparseDesignMatrixExp, install("i"), INTSXP, numSparseNonZeroes));
Memcpy(sdm_nonZeroRowIndices, testSparseDesignMatrixNonZeroRowIndices, numSparseNonZeroes);
int *sdm_indicesForColumn = INTEGER(ALLOC_SLOT(sparseDesignMatrixExp, install("p"), INTSXP, numObservations + 1));
Memcpy(sdm_indicesForColumn, testSparseDesignMatrixIndicesForColumn, numObservations + 1);
double *sdm_values = REAL(ALLOC_SLOT(sparseDesignMatrixExp, install("x"), REALSXP, numSparseNonZeroes));
Memcpy(sdm_values, testSparseDesignMatrixValues, numSparseNonZeroes);
// create and setup the A slot
SEXP rotatedSparseDesignMatrixExp = PROTECT(rotatedSparseDesignMatrixExp = NEW_OBJECT(MAKE_CLASS("dgCMatrix")));
++protectCount;
SET_SLOT(regression, lme4_ASym, rotatedSparseDesignMatrixExp);
int *rsdm_dims = INTEGER(ALLOC_SLOT(rotatedSparseDesignMatrixExp, install("Dim"), INTSXP, 2));
rsdm_dims[0] = numModeledCoef;
rsdm_dims[1] = numObservations;
int *rsdm_nonZeroRowIndices = INTEGER(ALLOC_SLOT(rotatedSparseDesignMatrixExp, install("i"), INTSXP, numSparseNonZeroes));
Memcpy(rsdm_nonZeroRowIndices, testSparseDesignMatrixNonZeroRowIndices, numSparseNonZeroes);
int *rsdm_indicesForColumn = INTEGER(ALLOC_SLOT(rotatedSparseDesignMatrixExp, install("p"), INTSXP, numObservations + 1));
Memcpy(rsdm_indicesForColumn, testSparseDesignMatrixIndicesForColumn, numObservations + 1);
ALLOC_SLOT(rotatedSparseDesignMatrixExp, install("x"), REALSXP, numSparseNonZeroes);
// ST slot
SEXP stExp = ALLOC_SLOT(regression, lme4_STSym, VECSXP, numFactors);
for (int i = 0; i < TEST_NUM_FACTORS; ++i) {
SEXP stExp_i = PROTECT(allocVector(REALSXP, testNumModeledCoefPerFactor[i] * testNumModeledCoefPerFactor[i]));
++protectCount;
SET_VECTOR_ELT(stExp, i, stExp_i);
SET_DIMS(stExp_i, testNumModeledCoefPerFactor[i], testNumModeledCoefPerFactor[i]);
double *stValues = REAL(stExp_i);
Memcpy(stValues, testSTDecompositions[i], testNumModeledCoefPerFactor[i] * testNumModeledCoefPerFactor[i]);
}
// L slot
SEXP upperLeftBlockLeftFactorizationExp = PROTECT(NEW_OBJECT(MAKE_CLASS("dCHMsimpl")));
++protectCount;
SET_SLOT(regression, lme4_LSym, upperLeftBlockLeftFactorizationExp);
int *ulfblf_permutation = INTEGER(ALLOC_SLOT(upperLeftBlockLeftFactorizationExp, install("perm"), INTSXP, numModeledCoef));
Memcpy(ulfblf_permutation, testFactorizationPermutation, numModeledCoef);
int *ulfblf_columnCounts = INTEGER(ALLOC_SLOT(upperLeftBlockLeftFactorizationExp, install("colcount"), INTSXP, numModeledCoef));
Memcpy(ulfblf_columnCounts, testFactorizationColumnCounts, numModeledCoef);
int numFactorizationNonZeroes = 0;
for (int i = 0; i < numModeledCoef; ++i) numFactorizationNonZeroes += ulfblf_columnCounts[i];
ALLOC_SLOT(upperLeftBlockLeftFactorizationExp, install("x"), REALSXP, numFactorizationNonZeroes);
int *ulfblf_indicesForColumn = INTEGER(ALLOC_SLOT(upperLeftBlockLeftFactorizationExp, install("p"), INTSXP, numModeledCoef + 1));
Memcpy(ulfblf_indicesForColumn, testFactorizationIndicesForColumn, numModeledCoef + 1);
int *ulfblf_nonZeroRowIndices = INTEGER(ALLOC_SLOT(upperLeftBlockLeftFactorizationExp, install("i"), INTSXP, numFactorizationNonZeroes));
Memcpy(ulfblf_nonZeroRowIndices, testFactorizationNonZeroRowIndices, numFactorizationNonZeroes);
int *ulfblf_numNonZeroes = INTEGER(ALLOC_SLOT(upperLeftBlockLeftFactorizationExp, install("nz"), INTSXP, numModeledCoef));
Memcpy(ulfblf_numNonZeroes, testFactorizationNumNonZeroes, numModeledCoef);
int *ulfblf_nextColumns = INTEGER(ALLOC_SLOT(upperLeftBlockLeftFactorizationExp, install("nxt"), INTSXP, numModeledCoef + 2));
Memcpy(ulfblf_nextColumns, testFactorizationNextColumns, numModeledCoef + 2);
int *ulfblf_prevColumns = INTEGER(ALLOC_SLOT(upperLeftBlockLeftFactorizationExp, install("prv"), INTSXP, numModeledCoef + 2));
Memcpy(ulfblf_prevColumns, testFactorizationPrevColumns, numModeledCoef + 2);
int *ulfblf_type = INTEGER(ALLOC_SLOT(upperLeftBlockLeftFactorizationExp, install("type"), INTSXP, 4));
Memcpy(ulfblf_type, testFactorizationType, 4);
int *ulfblf_dims = INTEGER(ALLOC_SLOT(upperLeftBlockLeftFactorizationExp, install("Dim"), INTSXP, 2));
ulfblf_dims[0] = ulfblf_dims[1] = numModeledCoef;
// misc slots
ALLOC_SLOT(regression, lme4_offsetSym, REALSXP, 0);
ALLOC_SLOT(regression, lme4_varSym, REALSXP, 0);
ALLOC_SLOT(regression, lme4_fixefSym, REALSXP, numUnmodeledCoef);
ALLOC_SLOT(regression, lme4_uSym, REALSXP, numModeledCoef);
ALLOC_SLOT(regression, lme4_CxSym, REALSXP, numSparseNonZeroes);
SEXP offDiagonalBlockRightFactorizationExp =
ALLOC_SLOT(regression, lme4_RXSym, REALSXP, numUnmodeledCoef * numUnmodeledCoef);
AZERO(REAL(offDiagonalBlockRightFactorizationExp), numUnmodeledCoef * numUnmodeledCoef);
SET_DIMS(offDiagonalBlockRightFactorizationExp, numUnmodeledCoef, numUnmodeledCoef);
SEXP lowerRightBlockRightFactorizationExp =
ALLOC_SLOT(regression, lme4_RZXSym, REALSXP, numModeledCoef * numUnmodeledCoef);
SET_DIMS(lowerRightBlockRightFactorizationExp, numModeledCoef, numUnmodeledCoef);
guaranteeValidPrior(regression);
// at this point, everything should be jammed into the regression
// or its objects
UNPROTECT(protectCount);
return (regression);
}
SEXP gCMatrix_colSums(SEXP x, SEXP NArm, SEXP spRes, SEXP trans, SEXP means)
{
int mn = asLogical(means), sp = asLogical(spRes), tr = asLogical(trans);
/* cholmod_sparse: drawback of coercing lgC to double: */
CHM_SP cx = AS_CHM_SP(x);
R_CheckStack();
if (tr) {
cholmod_sparse *cxt = cholmod_transpose(cx, (int)cx->xtype, &c);
cx = cxt;
}
/* everything else *after* the above potential transpose : */
/* Don't declarations here require the C99 standard? Can we assume C99? */
int j, nc = cx->ncol;
int *xp = (int *)(cx -> p);
#ifdef _has_x_slot_
int na_rm = asLogical(NArm), i, dnm = 0/*Wall*/;
double *xx = (double *)(cx -> x);
#endif
SEXP ans = PROTECT(sp ? NEW_OBJECT(MAKE_CLASS(SparseResult_class))
: allocVector(SXP_ans, nc));
if (sp) { /* sparseResult - never allocating length-nc ... */
int nza, i1, i2, p, *ai;
Type_ans *ax;
for (j = 0, nza = 0; j < nc; j++)
if(xp[j] < xp[j + 1])
nza++;
ai = INTEGER(ALLOC_SLOT(ans, Matrix_iSym, INTSXP, nza));
ax = STYP_ans(ALLOC_SLOT(ans, Matrix_xSym, SXP_ans, nza));
SET_SLOT(ans, Matrix_lengthSym, ScalarInteger(nc));
i2 = xp[0];
for (j = 1, p = 0; j <= nc; j++) {
/* j' =j+1, since 'i' slot will be 1-based */
i1 = i2; i2 = xp[j];
if(i1 < i2) {
Type_ans sum;
ColSUM_column(i1,i2, sum);
ai[p] = j;
ax[p++] = sum;
}
}
}
else { /* "numeric" (non sparse) result */
Type_ans *a = STYP_ans(ans);
for (j = 0; j < nc; j++) {
ColSUM_column(xp[j], xp[j + 1], a[j]);
}
}
if (tr) cholmod_free_sparse(&cx, &c);
UNPROTECT(1);
return ans;
}
