SEXP tmb_invQ(SEXP Lfac){ CHM_FR L=AS_CHM_FR(Lfac); cholmod_common c; M_R_cholmod_start(&c); CHM_SP iQ = tmb_inv_super(L, &c); return M_chm_sparse_to_SEXP(iQ, 1 /* Free */ , 0, 0, "", R_NilValue); }
void R_init_lme4a(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, (Rboolean)FALSE); M_R_cholmod_start(&c); c.final_ll = 1; /* LL' form of simplicial factorization */ }
void R_init_blme(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); M_R_cholmod_start(&cholmodCommon); cholmodCommon.final_ll = 1; /* LL' form of simplicial factorization */ lme4_ASym = install("A"); lme4_CmSym = install("Cm"); lme4_CxSym = install("Cx"); lme4_DimSym = install("Dim"); lme4_GpSym = install("Gp"); lme4_LSym = install("L"); lme4_RXSym = install("RX"); lme4_RZXSym = install("RZX"); lme4_STSym = install("ST"); lme4_VSym = install("V"); lme4_XSym = install("X"); lme4_XstSym = install("Xst"); lme4_ZtSym = install("Zt"); lme4_devianceSym = install("deviance"); lme4_dimsSym = install("dims"); lme4_envSym = install("env"); lme4_etaSym = install("eta"); lme4_fixefSym = install("fixef"); lme4_flistSym = install("flist"); lme4_ghwSym = install("ghw"); lme4_ghxSym = install("ghx"); lme4_gradientSym = install("gradient"); lme4_iSym = install("i"); lme4_ncSym = install("nc"); lme4_nlmodelSym = install("nlmodel"); lme4_muEtaSym = install("muEta"); lme4_muSym = install("mu"); lme4_offsetSym = install("offset"); lme4_pSym = install("p"); lme4_permSym = install("perm"); lme4_pWtSym = install("pWt"); lme4_ranefSym = install("ranef"); lme4_residSym = install("resid"); lme4_sigmaSym = install("sigma"); lme4_sqrtrWtSym = install("sqrtrWt"); lme4_sqrtXWtSym = install("sqrtXWt"); lme4_uSym = install("u"); lme4_varSym = install("var"); lme4_xSym = install("x"); lme4_ySym = install("y"); blme_covariancePriorSym = install("cov.prior"); blme_unmodeledCoefficientPriorSym = install("fixef.prior"); blme_commonScalePriorSym = install("var.prior"); blme_prior_typeSym = install("type"); blme_prior_familiesSym = install("families"); blme_prior_scalesSym = install("scales"); blme_prior_hyperparametersSym = install("hyperparameters"); }
SEXP tmb_invQ_tril_halfdiag(SEXP Lfac){ CHM_FR L=AS_CHM_FR(Lfac); cholmod_common c; M_R_cholmod_start(&c); CHM_SP iQ = tmb_inv_super(L, &c); half_diag(iQ); iQ->stype=0; /* Change to non-sym */ return M_chm_sparse_to_SEXP(iQ, 1 /* Free */ , 0, 0, "", R_NilValue); }
void R_init_lme4(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); M_R_cholmod_start(&c); c.final_ll = 1; /* LL' form of simplicial factorization */ /* need own error handler, that resets final_ll (after *_defaults()) : */ c.error_handler = lme4_R_cholmod_error; lme4_ASym = install("A"); lme4_CmSym = install("Cm"); lme4_CxSym = install("Cx"); lme4_DimSym = install("Dim"); lme4_GpSym = install("Gp"); lme4_LSym = install("L"); lme4_RXSym = install("RX"); lme4_RZXSym = install("RZX"); lme4_STSym = install("ST"); lme4_VSym = install("V"); lme4_XSym = install("X"); lme4_XstSym = install("Xst"); lme4_ZtSym = install("Zt"); lme4_devianceSym = install("deviance"); lme4_dimsSym = install("dims"); lme4_envSym = install("env"); lme4_etaSym = install("eta"); lme4_fixefSym = install("fixef"); lme4_flistSym = install("flist"); lme4_ghwSym = install("ghw"); lme4_ghxSym = install("ghx"); lme4_gradientSym = install("gradient"); lme4_iSym = install("i"); lme4_ncSym = install("nc"); lme4_nlmodelSym = install("nlmodel"); lme4_muEtaSym = install("muEta"); lme4_muSym = install("mu"); lme4_offsetSym = install("offset"); lme4_pSym = install("p"); lme4_permSym = install("perm"); lme4_pWtSym = install("pWt"); lme4_ranefSym = install("ranef"); lme4_residSym = install("resid"); lme4_sigmaSym = install("sigma"); lme4_sqrtrWtSym = install("sqrtrWt"); lme4_sqrtXWtSym = install("sqrtXWt"); lme4_uSym = install("u"); lme4_varSym = install("var"); lme4_xSym = install("x"); lme4_ySym = install("y"); }
/* * 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; }