SEXP Csparse_dense_prod(SEXP a, SEXP b) { CHM_SP cha = AS_CHM_SP(a); SEXP b_M = PROTECT(mMatrix_as_dgeMatrix(b)); CHM_DN chb = AS_CHM_DN(b_M); CHM_DN chc = cholmod_l_allocate_dense(cha->nrow, chb->ncol, cha->nrow, chb->xtype, &c); SEXP dn = PROTECT(allocVector(VECSXP, 2)); double one[] = {1,0}, zero[] = {0,0}; int nprot = 2; R_CheckStack(); /* Tim Davis, please FIXME: currently (2010-11) *fails* when a is a pattern matrix:*/ if(cha->xtype == CHOLMOD_PATTERN) { /* warning(_("Csparse_dense_prod(): cholmod_sdmult() not yet implemented for pattern./ ngCMatrix" */ /* " --> slightly inefficient coercion")); */ // This *fails* to produce a CHOLMOD_REAL .. // CHM_SP chd = cholmod_l_copy(cha, cha->stype, CHOLMOD_REAL, &c); // --> use our Matrix-classes SEXP da = PROTECT(nz2Csparse(a, x_double)); nprot++; cha = AS_CHM_SP(da); } cholmod_l_sdmult(cha, 0, one, zero, chb, chc, &c); SET_VECTOR_ELT(dn, 0, /* establish dimnames */ duplicate(VECTOR_ELT(GET_SLOT(a, Matrix_DimNamesSym), 0))); SET_VECTOR_ELT(dn, 1, duplicate(VECTOR_ELT(GET_SLOT(b_M, Matrix_DimNamesSym), 1))); UNPROTECT(nprot); return chm_dense_to_SEXP(chc, 1, 0, dn); }
/* Given sparse matrices A and B (sorted columns). Assume pattern of A is a subset of pattern of B. (This also includes cases where dimension of B larger than dim of A) Return integer vector p of same length as A@x such that " A@i == B@i[p] and A@j == B@j[p] " */ SEXP match_pattern(SEXP A_, SEXP B_){ CHM_SP A=AS_CHM_SP(A_); CHM_SP B=AS_CHM_SP(B_); int *Ai=A->i, *Bi=B->i, *Ap=A->p, *Bp=B->p; int ncol=A->ncol,i,j,k; int index; // index match SEXP ans; if(A->ncol>B->ncol)error("Must have dim(A)<=dim(B)"); PROTECT(ans=NEW_INTEGER(A->nzmax)); int *pans=INTEGER(ans); for(j=0;j<ncol;j++){ index=Bp[j]; // Start at top of B(:,j) for(k=Ap[j];k<Ap[j+1];k++){ i=Ai[k]; for(;Bi[index]!=i;index++){ // Find next match if(index>=Bp[j+1]){ UNPROTECT(1); error("No match"); } } *pans=index+1; pans++; // R-index ! } } UNPROTECT(1); return ans; }
/** * "Indexing" aka subsetting : Compute x[i,j], also for vectors i and j * Working via CHOLMOD_submatrix, see ./CHOLMOD/MatrixOps/cholmod_submatrix.c * @param x CsparseMatrix * @param i row indices (0-origin), or NULL (R's) * @param j columns indices (0-origin), or NULL * * @return x[i,j] still CsparseMatrix --- currently, this loses dimnames */ SEXP Csparse_submatrix(SEXP x, SEXP i, SEXP j) { CHM_SP chx = AS_CHM_SP(x); /* << does diagU2N() when needed */ int rsize = (isNull(i)) ? -1 : LENGTH(i), csize = (isNull(j)) ? -1 : LENGTH(j); int Rkind = (chx->xtype != CHOLMOD_PATTERN) ? Real_kind(x) : 0; R_CheckStack(); if (rsize >= 0 && !isInteger(i)) error(_("Index i must be NULL or integer")); if (csize >= 0 && !isInteger(j)) error(_("Index j must be NULL or integer")); if (!chx->stype) {/* non-symmetric Matrix */ return chm_sparse_to_SEXP(cholmod_submatrix(chx, (rsize < 0) ? NULL : INTEGER(i), rsize, (csize < 0) ? NULL : INTEGER(j), csize, TRUE, TRUE, &c), 1, 0, Rkind, "", /* FIXME: drops dimnames */ R_NilValue); } /* for now, cholmod_submatrix() only accepts "generalMatrix" */ CHM_SP tmp = cholmod_copy(chx, /* stype: */ 0, chx->xtype, &c); CHM_SP ans = cholmod_submatrix(tmp, (rsize < 0) ? NULL : INTEGER(i), rsize, (csize < 0) ? NULL : INTEGER(j), csize, TRUE, TRUE, &c); cholmod_free_sparse(&tmp, &c); return chm_sparse_to_SEXP(ans, 1, 0, Rkind, "", R_NilValue); }
// called from package MatrixModels's R code: SEXP dgCMatrix_cholsol(SEXP x, SEXP y) { /* Solve Sparse Least Squares X %*% beta ~= y with dense RHS y, * where X = t(x) i.e. we pass x = t(X) as argument, * via "Cholesky(X'X)" .. well not really: * cholmod_factorize("x", ..) finds L in X'X = L'L directly */ CHM_SP cx = AS_CHM_SP(x); /* FIXME: extend this to work in multivariate case, i.e. y a matrix with > 1 column ! */ CHM_DN cy = AS_CHM_DN(coerceVector(y, REALSXP)), rhs, cAns, resid; CHM_FR L; int n = cx->ncol;/* #{obs.} {x = t(X) !} */ double one[] = {1,0}, zero[] = {0,0}, neg1[] = {-1,0}; const char *nms[] = {"L", "coef", "Xty", "resid", ""}; SEXP ans = PROTECT(Rf_mkNamed(VECSXP, nms)); R_CheckStack(); if (n < cx->nrow || n <= 0) error(_("dgCMatrix_cholsol requires a 'short, wide' rectangular matrix")); if (cy->nrow != n) error(_("Dimensions of system to be solved are inconsistent")); rhs = cholmod_allocate_dense(cx->nrow, 1, cx->nrow, CHOLMOD_REAL, &c); /* cholmod_sdmult(A, transp, alpha, beta, X, Y, &c): * Y := alpha*(A*X) + beta*Y or alpha*(A'*X) + beta*Y ; * here: rhs := 1 * x %*% y + 0 = x %*% y = X'y */ if (!(cholmod_sdmult(cx, 0 /* trans */, one, zero, cy, rhs, &c))) error(_("cholmod_sdmult error (rhs)")); L = cholmod_analyze(cx, &c); if (!cholmod_factorize(cx, L, &c)) error(_("cholmod_factorize failed: status %d, minor %d from ncol %d"), c.status, L->minor, L->n); /* FIXME: Do this in stages so an "effects" vector can be calculated */ if (!(cAns = cholmod_solve(CHOLMOD_A, L, rhs, &c))) error(_("cholmod_solve (CHOLMOD_A) failed: status %d, minor %d from ncol %d"), c.status, L->minor, L->n); /* L : */ SET_VECTOR_ELT(ans, 0, chm_factor_to_SEXP(L, 0)); /* coef : */ SET_VECTOR_ELT(ans, 1, allocVector(REALSXP, cx->nrow)); Memcpy(REAL(VECTOR_ELT(ans, 1)), (double*)(cAns->x), cx->nrow); /* X'y : */ /* FIXME: Change this when the "effects" vector is available */ SET_VECTOR_ELT(ans, 2, allocVector(REALSXP, cx->nrow)); Memcpy(REAL(VECTOR_ELT(ans, 2)), (double*)(rhs->x), cx->nrow); /* resid := y */ resid = cholmod_copy_dense(cy, &c); /* cholmod_sdmult(A, transp, alp, bet, X, Y, &c): * Y := alp*(A*X) + bet*Y or alp*(A'*X) + beta*Y ; * here: resid := -1 * x' %*% coef + 1 * y = y - X %*% coef */ if (!(cholmod_sdmult(cx, 1/* trans */, neg1, one, cAns, resid, &c))) error(_("cholmod_sdmult error (resid)")); /* FIXME: for multivariate case, i.e. resid *matrix* with > 1 column ! */ SET_VECTOR_ELT(ans, 3, allocVector(REALSXP, n)); Memcpy(REAL(VECTOR_ELT(ans, 3)), (double*)(resid->x), n); cholmod_free_factor(&L, &c); cholmod_free_dense(&rhs, &c); cholmod_free_dense(&cAns, &c); UNPROTECT(1); return ans; }
SEXP Csparse_Csparse_prod(SEXP a, SEXP b) { CHM_SP cha = AS_CHM_SP(a), chb = AS_CHM_SP(b), chc = cholmod_l_ssmult(cha, chb, /*out_stype:*/ 0, /* values:= is_numeric (T/F) */ cha->xtype > 0, /*out sorted:*/ 1, &c); const char *cl_a = class_P(a), *cl_b = class_P(b); char diag[] = {'\0', '\0'}; int uploT = 0; SEXP dn = PROTECT(allocVector(VECSXP, 2)); R_CheckStack(); #ifdef DEBUG_Matrix_verbose Rprintf("DBG Csparse_C*_prod(%s, %s)\n", cl_a, cl_b); #endif /* Preserve triangularity and even unit-triangularity if appropriate. * Note that in that case, the multiplication itself should happen * faster. But there's no support for that in CHOLMOD */ /* UGLY hack -- rather should have (fast!) C-level version of * is(a, "triangularMatrix") etc */ if (cl_a[1] == 't' && cl_b[1] == 't') /* FIXME: fails for "Cholesky","BunchKaufmann"..*/ if(*uplo_P(a) == *uplo_P(b)) { /* both upper, or both lower tri. */ uploT = (*uplo_P(a) == 'U') ? 1 : -1; if(*diag_P(a) == 'U' && *diag_P(b) == 'U') { /* return UNIT-triag. */ /* "remove the diagonal entries": */ chm_diagN2U(chc, uploT, /* do_realloc */ FALSE); diag[0]= 'U'; } else diag[0]= 'N'; } SET_VECTOR_ELT(dn, 0, /* establish dimnames */ duplicate(VECTOR_ELT(GET_SLOT(a, Matrix_DimNamesSym), 0))); SET_VECTOR_ELT(dn, 1, duplicate(VECTOR_ELT(GET_SLOT(b, Matrix_DimNamesSym), 1))); UNPROTECT(1); return chm_sparse_to_SEXP(chc, 1, uploT, /*Rkind*/0, diag, dn); }
SEXP dsCMatrix_Csparse_solve(SEXP a, SEXP b) { CHM_FR L = internal_chm_factor(a, -1, -1, -1, 0.); CHM_SP cx, cb = AS_CHM_SP(b); R_CheckStack(); cx = cholmod_l_spsolve(CHOLMOD_A, L, cb, &c); cholmod_l_free_factor(&L, &c); return chm_sparse_to_SEXP(cx, /*do_free*/ 1, /*uploT*/ 0, /*Rkind*/ 0, /*diag*/ "N", /*dimnames = */ R_NilValue); }
SEXP Csparse_MatrixMarket(SEXP x, SEXP fname) { FILE *f = fopen(CHAR(asChar(fname)), "w"); if (!f) error(_("failure to open file \"%s\" for writing"), CHAR(asChar(fname))); if (!cholmod_l_write_sparse(f, AS_CHM_SP(x), (CHM_SP)NULL, (char*) NULL, &c)) error(_("cholmod_l_write_sparse returned error code")); fclose(f); return R_NilValue; }
SEXP Csparse_dense_crossprod(SEXP a, SEXP b) { CHM_SP cha = AS_CHM_SP(a); SEXP b_M = PROTECT(mMatrix_as_dgeMatrix(b)); CHM_DN chb = AS_CHM_DN(b_M); CHM_DN chc = cholmod_l_allocate_dense(cha->ncol, chb->ncol, cha->ncol, chb->xtype, &c); SEXP dn = PROTECT(allocVector(VECSXP, 2)); int nprot = 2; double one[] = {1,0}, zero[] = {0,0}; R_CheckStack(); // -- see Csparse_dense_prod() above : if(cha->xtype == CHOLMOD_PATTERN) { SEXP da = PROTECT(nz2Csparse(a, x_double)); nprot++; cha = AS_CHM_SP(da); } cholmod_l_sdmult(cha, 1, one, zero, chb, chc, &c); SET_VECTOR_ELT(dn, 0, /* establish dimnames */ duplicate(VECTOR_ELT(GET_SLOT(a, Matrix_DimNamesSym), 1))); SET_VECTOR_ELT(dn, 1, duplicate(VECTOR_ELT(GET_SLOT(b_M, Matrix_DimNamesSym), 1))); UNPROTECT(nprot); return chm_dense_to_SEXP(chc, 1, 0, dn); }
SEXP Csparse_Csparse_crossprod(SEXP a, SEXP b, SEXP trans) { int tr = asLogical(trans); CHM_SP cha = AS_CHM_SP(a), chb = AS_CHM_SP(b), chTr, chc; const char *cl_a = class_P(a), *cl_b = class_P(b); char diag[] = {'\0', '\0'}; int uploT = 0; SEXP dn = PROTECT(allocVector(VECSXP, 2)); R_CheckStack(); chTr = cholmod_l_transpose((tr) ? chb : cha, chb->xtype, &c); chc = cholmod_l_ssmult((tr) ? cha : chTr, (tr) ? chTr : chb, /*out_stype:*/ 0, cha->xtype, /*out sorted:*/ 1, &c); cholmod_l_free_sparse(&chTr, &c); /* Preserve triangularity and unit-triangularity if appropriate; * see Csparse_Csparse_prod() for comments */ if (cl_a[1] == 't' && cl_b[1] == 't') if(*uplo_P(a) != *uplo_P(b)) { /* one 'U', the other 'L' */ uploT = (*uplo_P(b) == 'U') ? 1 : -1; if(*diag_P(a) == 'U' && *diag_P(b) == 'U') { /* return UNIT-triag. */ chm_diagN2U(chc, uploT, /* do_realloc */ FALSE); diag[0]= 'U'; } else diag[0]= 'N'; } SET_VECTOR_ELT(dn, 0, /* establish dimnames */ duplicate(VECTOR_ELT(GET_SLOT(a, Matrix_DimNamesSym), (tr) ? 0 : 1))); SET_VECTOR_ELT(dn, 1, duplicate(VECTOR_ELT(GET_SLOT(b, Matrix_DimNamesSym), (tr) ? 0 : 1))); UNPROTECT(1); return chm_sparse_to_SEXP(chc, 1, uploT, /*Rkind*/0, diag, dn); }
/** * Return a SuiteSparse QR factorization of the sparse matrix A * * @param Ap (pointer to) a [m x n] dgCMatrix * @param ordering integer SEXP specifying the ordering strategy to be used * see SPQR/Include/SuiteSparseQR_definitions.h * @param econ integer SEXP ("economy"): number of rows of R and columns of Q * to return. The default is m. Using n gives the standard economy form. * A value less than the estimated rank r is set to r, so econ=0 gives the * "rank-sized" factorization, where nrow(R)==nnz(diag(R))==r. * @param tol double SEXP: if tol <= -2 use SPQR's default, * if -2 < tol < 0, then no tol is used; otherwise, * tol > 0, use as tolerance: columns with 2-norm <= tol treated as 0 * * * @return SEXP "SPQR" object with slots (Q, R, p, rank, Dim): * Q: dgCMatrix; R: dgCMatrix [subject to change to dtCMatrix FIXME ?] * p: integer: 0-based permutation (or length 0 <=> identity); * rank: integer, the "revealed" rank Dim: integer, original matrix dim. */ SEXP dgCMatrix_SPQR(SEXP Ap, SEXP ordering, SEXP econ, SEXP tol) { /* SEXP ans = PROTECT(allocVector(VECSXP, 4)); */ SEXP ans = PROTECT(NEW_OBJECT(MAKE_CLASS("SPQR"))); CHM_SP A = AS_CHM_SP(Ap), Q, R; SuiteSparse_long *E, rank;/* not always = int FIXME (Windows_64 ?) */ if ((rank = SuiteSparseQR_C_QR(asInteger(ordering), asReal(tol),/* originally had SPQR_DEFAULT_TOL */ (SuiteSparse_long)asInteger(econ),/* originally had 0 */ A, &Q, &R, &E, &cl)) == -1) error(_("SuiteSparseQR_C_QR returned an error code")); slot_dup(ans, Ap, Matrix_DimSym); /* SET_VECTOR_ELT(ans, 0, */ /* chm_sparse_to_SEXP(Q, 0, 0, 0, "", R_NilValue)); */ SET_SLOT(ans, install("Q"), chm_sparse_to_SEXP(Q, 0, 0, 0, "", R_NilValue)); /* Also gives a dgCMatrix (not a dtC* *triangular*) : * may make sense if to be used in the "spqr_solve" routines .. ?? */ /* SET_VECTOR_ELT(ans, 1, */ /* chm_sparse_to_SEXP(R, 0, 0, 0, "", R_NilValue)); */ SET_SLOT(ans, install("R"), chm_sparse_to_SEXP(R, 0, 0, 0, "", R_NilValue)); cholmod_free_sparse(&Al, &cl); cholmod_free_sparse(&R, &cl); cholmod_free_sparse(&Q, &cl); if (E) { int *Er; SET_VECTOR_ELT(ans, 2, allocVector(INTSXP, A->ncol)); Er = INTEGER(VECTOR_ELT(ans, 2)); for (int i = 0; i < A->ncol; i++) Er[i] = (int) E[i]; Free(E); } else SET_VECTOR_ELT(ans, 2, allocVector(INTSXP, 0)); SET_VECTOR_ELT(ans, 3, ScalarInteger((int)rank)); UNPROTECT(1); return ans; }
/* Computes x'x or x x' -- *also* for Tsparse (triplet = TRUE) see Csparse_Csparse_crossprod above for x'y and x y' */ SEXP Csparse_crossprod(SEXP x, SEXP trans, SEXP triplet) { int trip = asLogical(triplet), tr = asLogical(trans); /* gets reversed because _aat is tcrossprod */ #ifdef AS_CHM_DIAGU2N_FIXED_FINALLY CHM_TR cht = trip ? AS_CHM_TR(x) : (CHM_TR) NULL; #else /* workaround needed:*/ SEXP xx = PROTECT(Tsparse_diagU2N(x)); CHM_TR cht = trip ? AS_CHM_TR__(xx) : (CHM_TR) NULL; #endif CHM_SP chcp, chxt, chx = (trip ? cholmod_l_triplet_to_sparse(cht, cht->nnz, &c) : AS_CHM_SP(x)); SEXP dn = PROTECT(allocVector(VECSXP, 2)); R_CheckStack(); if (!tr) chxt = cholmod_l_transpose(chx, chx->xtype, &c); chcp = cholmod_l_aat((!tr) ? chxt : chx, (int *) NULL, 0, chx->xtype, &c); if(!chcp) { UNPROTECT(1); error(_("Csparse_crossprod(): error return from cholmod_l_aat()")); } cholmod_l_band_inplace(0, chcp->ncol, chcp->xtype, chcp, &c); chcp->stype = 1; if (trip) cholmod_l_free_sparse(&chx, &c); if (!tr) cholmod_l_free_sparse(&chxt, &c); SET_VECTOR_ELT(dn, 0, /* establish dimnames */ duplicate(VECTOR_ELT(GET_SLOT(x, Matrix_DimNamesSym), (tr) ? 0 : 1))); SET_VECTOR_ELT(dn, 1, duplicate(VECTOR_ELT(dn, 0))); #ifdef AS_CHM_DIAGU2N_FIXED_FINALLY UNPROTECT(1); #else UNPROTECT(2); #endif return chm_sparse_to_SEXP(chcp, 1, 0, 0, "", dn); }
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; }
/* * callable function from R */ SEXP gmrfLik( SEXP QR, SEXP obsCovR, SEXP xisqTausq, SEXP YrepAddR ){ int Drep, dooptim, DxisqAgain; // length(xisqTausq) double oneD=1.0, zeroD=0.0; double optTol = pow(DBL_EPSILON, 0.25); // tolerence for fmin_brent double optMin = log(0.01), optMax = log(100); // default interval for optimizer int NxisqMax = 100; // number of xisqTausq's to retain when optimizing double *YXVYX, *determinant, *determinantForReml; double *m2logL, *m2logReL, *varHatMl, *varHatReml, *resultXisqTausq; void *nothing; SEXP resultR; CHM_DN obsCov; Ltype=0; // set to 1 for reml Nrep =LENGTH(YrepAddR); YrepAdd = REAL(YrepAddR); Nobs = INTEGER(GET_DIM(obsCovR))[0]; Nxy = INTEGER(GET_DIM(obsCovR))[1]; Ncov = Nxy - Nrep; Nxysq = Nxy*Nxy; NxisqTausq = LENGTH(xisqTausq); // if length zero, do optimization dooptim=!NxisqTausq; if(dooptim){ NxisqTausq = NxisqMax; } // Rprintf("d %d %d", dooptim, NxisqTausq); resultR = PROTECT(allocVector(REALSXP, Nxysq*NxisqTausq + 8*Nrep*NxisqTausq)); YXVYX = REAL(resultR); determinant = &REAL(resultR)[Nxysq*NxisqTausq]; determinantForReml = &REAL(resultR)[Nxysq*NxisqTausq + Nrep*NxisqTausq]; m2logL = &REAL(resultR)[Nxysq*NxisqTausq + 2*Nrep*NxisqTausq]; m2logReL = &REAL(resultR)[Nxysq*NxisqTausq + 3*Nrep*NxisqTausq]; varHatMl = &REAL(resultR)[Nxysq*NxisqTausq + 4*Nrep*NxisqTausq]; varHatReml = &REAL(resultR)[Nxysq*NxisqTausq + 5*Nrep*NxisqTausq]; resultXisqTausq = &REAL(resultR)[Nxysq*NxisqTausq + 6*Nrep*NxisqTausq]; YXYX = (double *) calloc(Nxysq,sizeof(double)); copyLx = (double *) calloc(Nxy*Nrep,sizeof(double)); Q = AS_CHM_SP(QR); obsCov = AS_CHM_DN(obsCovR); M_R_cholmod_start(&c); // get some stuff ready // allocate Lx Lx = M_cholmod_copy_dense(obsCov,&c); // likelihood without nugget // YX Vinv YX M_cholmod_sdmult( Q, 0, &oneD, &zeroD, // transpose, scale, scale obsCov,Lx,// in, out &c); // put t(obscov) Q obscov in result F77_NAME(dgemm)( // op(A), op(B), "T", "N", // nrows of op(A), ncol ob(B), ncol op(A) = nrow(opB) &Nxy, &Nxy, &Nobs, // alpha &oneD, // A, nrow(A) obsCov->x, &Nobs, // B, nrow(B) Lx->x, &Nobs, // beta &zeroD, // C, nrow(c) YXVYX, &Nxy); // Q = P' L D L' P L = M_cholmod_analyze(Q, &c); M_cholmod_factorize(Q,L, &c); // determinant determinant[0] = M_chm_factor_ldetL2(L); resultXisqTausq[0]= R_PosInf; ssqFromXprod( YXVYX, // N by N determinantForReml, Nxy, Nrep, copyLx); for(Drep=0;Drep<Nrep;++Drep){ determinant[Drep] = determinant[0]; determinantForReml[Drep] = determinantForReml[0]; m2logL[Drep] = Nobs*log(YXVYX[Drep*Nxy+Drep]) - Nobs*log(Nobs) - determinant[0] - YrepAdd[Drep]; m2logReL[Drep] = (Nobs-Ncov)*log(YXVYX[Drep*Nxy+Drep]/(Nobs-Ncov)) + determinantForReml[0] - determinant[0] - YrepAdd[Drep]; varHatMl[Drep] = YXVYX[Drep*Nxy+Drep]/Nobs; varHatReml[Drep] = YXVYX[Drep*Nxy+Drep]/(Nobs-Ncov); } // now with xisqTausq obsCovRot = M_cholmod_solve(CHOLMOD_P, L,obsCov,&c); // YXYX cross product of data F77_NAME(dgemm)( // op(A), op(B), "T", "N", // nrows of op(A), ncol ob(B), ncol op(A) = nrow(opB) &Nxy, &Nxy, &Nobs, // alpha &oneD, // A, nrow(A) obsCovRot->x, &Nobs, // B, nrow(B) obsCovRot->x, &Nobs, // beta &zeroD, // C, nrow(&c) YXYX, &Nxy); YXVYXglobal = YXVYX; // Rprintf("done zero ", dooptim); if(dooptim){ // put NA's where DxisqTausq hasnt been used for(DxisqAgain=1;DxisqAgain < NxisqTausq; ++DxisqAgain){ determinant[DxisqAgain*Nrep] = NA_REAL; determinantForReml[DxisqAgain*Nrep] = NA_REAL; m2logL[DxisqAgain*Nrep] = NA_REAL; m2logReL[DxisqAgain*Nrep] = NA_REAL; varHatMl[DxisqAgain*Nrep] = NA_REAL; varHatReml[DxisqAgain*Nrep] = NA_REAL; } DxisqTausq=1; // do optimizer Brent_fmin( optMin, optMax, logLoneLogNugget, nothing, optTol); // Rprintf("done opt ", dooptim); NxisqTausq = DxisqTausq; } else { for(DxisqTausq=1;DxisqTausq < NxisqTausq;++DxisqTausq){ logLoneNugget(REAL(xisqTausq)[DxisqTausq], nothing); } } // assign global values into their correct spot for(DxisqTausq=1;DxisqTausq < NxisqTausq;++DxisqTausq){ for(Drep=0;Drep<Nrep;++Drep){ determinant[DxisqTausq*Nrep+Drep] = determinant[DxisqTausq*Nrep]; determinantForReml[DxisqTausq*Nrep+Drep]= determinantForReml[DxisqTausq*Nrep]; m2logL[DxisqTausq*Nrep+Drep] -= determinant[0]; m2logReL[DxisqTausq*Nrep+Drep] -= determinant[0]; varHatMl[DxisqTausq*Nrep + Drep] = YXVYXglobal[DxisqTausq*Nxysq+Drep*Nxy+Drep]/Nobs; varHatReml[DxisqTausq*Nrep + Drep] = YXVYXglobal[DxisqTausq*Nxysq+Drep*Nxy+Drep]/(Nobs-Ncov); resultXisqTausq[DxisqTausq*Nrep + Drep] = resultXisqTausq[DxisqTausq*Nrep]; } } M_cholmod_free_factor(&L, &c); M_cholmod_free_dense(&obsCovRot, &c); M_cholmod_free_dense(&Lx, &c); // don't free Q because it's from an R object // M_cholmod_free_sparse(&Q, &c); // don't free obsCov because it's from an R object // M_cholmod_free_dense(&obsCov, &c); free(copyLx); free(YXYX); M_cholmod_free_dense(&YwkL, &c); M_cholmod_free_dense(&YwkD, &c); M_cholmod_free_dense(&EwkL, &c); M_cholmod_free_dense(&EwkD, &c); M_cholmod_finish(&c); UNPROTECT(1); return resultR; }