Пример #1
0
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;
}
Пример #2
0
/**
 * 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;
}
Пример #3
0
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;
}
Пример #4
0
/**
 * 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;
}
Пример #5
0
/**
 * 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;
}
Пример #6
0
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;
}
Пример #7
0
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");
}
Пример #8
0
/* 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");
}
Пример #9
0
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;
}
Пример #10
0
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;
}
Пример #11
0
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");
}
Пример #12
0
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");
}
Пример #13
0
// 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;
}
Пример #14
0
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;
}
Пример #15
0
// 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;
}
Пример #16
0
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;
}
Пример #17
0
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;
}
Пример #18
0
/* 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;
}
Пример #19
0
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;
}
Пример #20
0
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;
}
Пример #21
0
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;
}
Пример #22
0
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;
}
Пример #23
0
/* 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;
}
Пример #24
0
// 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;
}
Пример #25
0
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;
}
Пример #26
0
/* 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;
}
Пример #27
0
/* 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;
}
Пример #28
0
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;
}
Пример #29
0
// 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);
}
Пример #30
0
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;
}