/** * Evaluate the conditional deviance for a given set of fixed effects. * * @param GS Pointer to a GlmerStruct * @param fixed value of the fixed effects * * @return conditional deviance */ static double fixed_effects_deviance(GlmerStruct GS, const double fixed[]) { SEXP devs; int i, ione = 1; double ans, one = 1, zero = 0; F77_CALL(dgemv)("N", &(GS->n), &(GS->p), &one, GS->X, &(GS->n), fixed, &ione, &zero, REAL(GS->eta), &ione); /* add in random effects and offset */ vecIncrement(REAL(GS->eta), GS->off, GS->n); eval_check_store(GS->linkinv, GS->rho, GS->mu); devs = PROTECT(eval_check(GS->dev_resids, GS->rho, REALSXP, GS->n)); for (i = 0, ans = 0; i < GS->n; i++) ans += REAL(devs)[i]; UNPROTECT(1); return ans; }
static int funobj(int *MODE, int *N, double *X, double *F, double *G, int *NSTATE, char *cu, int *lencu, int *iu, int *leniu, double *ru, int *lenru, ftnlen cu_len) { Optimizer1 *D; Snopt_Details *T; int asv_req; T = snopt_details; D = T->D; if (eval_check(&asv_req, MODE, X)) { *MODE = -2; return 0; } if (asv_req & 1) GetFuncs(D, 0, 1, F); if (asv_req & 2) GetGrads(D, 0, 1, T->n, T->n, 1, G); return 0; }
static int funcon(int *MODE, int *M1, int *N, int *NJAC, double *X, double *F, double *G, int *NSTATE, char *CU, int *LENCU, int *IU, int *LENIU, double *RU, int *LENRU, ftnlen len_cu) { Optimizer1 *D; Snopt_Details *T; int asv_req, co, nnlc; T = snopt_details; D = T->D; nnlc = T->nnlc; if (eval_check(&asv_req, MODE, X)) { *MODE = -2; return 0; } co = T->co; if (asv_req & 1) GetFuncs(D, co, co + nnlc, F); if (asv_req & 2) GetGrads(D, co, co + nnlc, T->n, 1, T->m, G); return 0; }
/** * Determine the conditional modes and the conditional variance of the * fixed effects given the data and the current random effects. * Create a Metropolis-Hasting proposal step from the multivariate * normal density, determine the acceptance probability and, if the * step is to be accepted, overwrite the contents of fixed with the * new contents. * * @param GS a GlmerStruct * @param b list of random effects * @param fixed current value of the fixed effects * * @return updated value of the fixed effects */ static double * internal_glmer_fixef_update(GlmerStruct GS, SEXP b, double fixed[]) { SEXP dmu_deta, var; int i, ione = 1, it, j, lwork = -1; double *ans = Calloc(GS->p, double), /* proposal point */ *md = Calloc(GS->p, double), /* conditional modes */ *w = Calloc(GS->n, double), *work, *wtd = Calloc(GS->n * GS->p, double), *z = Calloc(GS->n, double), crit, devr, one = 1, tmp, zero = 0; if (!isNewList(b) || LENGTH(b) != GS->nf) error(_("%s must be a %s of length %d"), "b", "list", GS->nf); for (i = 0; i < GS->nf; i++) { SEXP bi = VECTOR_ELT(b, i); if (!isReal(bi) || !isMatrix(bi)) error(_("b[[%d]] must be a numeric matrix"), i); } AZERO(z, GS->n); /* -Wall */ Memcpy(md, fixed, GS->p); /* calculate optimal size of work array */ F77_CALL(dgels)("N", &(GS->n), &(GS->p), &ione, wtd, &(GS->n), z, &(GS->n), &tmp, &lwork, &j); if (j) /* shouldn't happen */ error(_("%s returned error code %d"), "dgels", j); lwork = (int) tmp; work = Calloc(lwork, double); AZERO(GS->off, GS->n); /* fitted values from random effects */ /* fitted_ranef(GET_SLOT(GS->mer, lme4_flistSym), GS->unwtd, b, */ /* INTEGER(GET_SLOT(GS->mer, lme4_ncSym)), GS->off); */ for (i = 0; i < GS->n; i++) (GS->etaold)[i] = ((GS->off)[i] += (GS->offset)[i]); for (it = 0, crit = GS->tol + 1; it < GS->maxiter && crit > GS->tol; it++) { /* fitted values from current beta */ F77_CALL(dgemv)("N", &(GS->n), &(GS->p), &one, GS->X, &(GS->n), md, &ione, &zero, REAL(GS->eta), &ione); /* add in random effects and offset */ vecIncrement(REAL(GS->eta), (GS->off), GS->n); /* check for convergence */ crit = conv_crit(GS->etaold, REAL(GS->eta), GS->n); /* obtain mu, dmu_deta, var */ eval_check_store(GS->linkinv, GS->rho, GS->mu); dmu_deta = PROTECT(eval_check(GS->mu_eta, GS->rho, REALSXP, GS->n)); var = PROTECT(eval_check(GS->var, GS->rho, REALSXP, GS->n)); /* calculate weights and working residual */ for (i = 0; i < GS->n; i++) { w[i] = GS->wts[i] * REAL(dmu_deta)[i]/sqrt(REAL(var)[i]); z[i] = w[i] * (REAL(GS->eta)[i] - (GS->off)[i] + ((GS->y)[i] - REAL(GS->mu)[i]) / REAL(dmu_deta)[i]); } UNPROTECT(2); /* weighted copy of the model matrix */ for (j = 0; j < GS->p; j++) for (i = 0; i < GS->n; i++) wtd[i + j * GS->n] = GS->X[i + j * GS->n] * w[i]; /* weighted least squares solution */ F77_CALL(dgels)("N", &(GS->n), &(GS->p), &ione, wtd, &(GS->n), z, &(GS->n), work, &lwork, &j); if (j) error(_("%s returned error code %d"), "dgels", j); Memcpy(md, z, GS->p); } /* wtd contains the Cholesky factor of * the precision matrix */ devr = normal_kernel(GS->p, md, wtd, GS->n, fixed); devr -= fixed_effects_deviance(GS, fixed); for (i = 0; i < GS->p; i++) { double var = norm_rand(); ans[i] = var; devr -= var * var; } F77_CALL(dtrsv)("U", "N", "N", &(GS->p), wtd, &(GS->n), ans, &ione); for (i = 0; i < GS->p; i++) ans[i] += md[i]; devr += fixed_effects_deviance(GS, ans); crit = exp(-0.5 * devr); /* acceptance probability */ tmp = unif_rand(); if (asLogical(internal_getElement(GS->cv, "msVerbose"))) { Rprintf("%5.3f: ", crit); for (j = 0; j < GS->p; j++) Rprintf("%#10g ", ans[j]); Rprintf("\n"); } if (tmp < crit) Memcpy(fixed, ans, GS->p); Free(ans); Free(md); Free(w); Free(work); Free(wtd); Free(z); return fixed; }
/** * Determine the deviance components associated with each of the * levels of a grouping factor at the conditional modes or a value * offset from the conditional modes by delb. * * @param GS pointer to a GlmerStruct * @param b conditional modes of the random effects * @param Gp group pointers * @param nc number of columns in the model matrix for the kth * grouping factor * @param k index (0-based) of the grouping factor * @param delb vector of length nc giving the changes in the * orthonormalized random effects * @param OmgFac Cholesky factor of the inverse of the penalty matrix * for this grouping factor * @param bVfac 3-dimensional array holding the factors of the * conditional variance-covariance matrix of the random effects FIXME: This is wrong. It is bVar[[i]] not bVfac that is being passed. This only affects the AGQ method. * @param devcmp array to hold the deviance components * * @return devcmp */ static double* rel_dev_1(GlmerStruct GS, const double b[], int nlev, int nc, int k, const double delb[], const double OmgFac[], const double bVfac[], double devcmp[]) { SEXP devs; int *fv = INTEGER(VECTOR_ELT(GET_SLOT(GS->mer, lme4_flistSym), k)), i, j; double *bcp = (double *) NULL; AZERO(devcmp, nlev); if (delb) { int ione = 1, ntot = nlev * nc; double sumsq = 0; /* copy the contents of b */ bcp = Memcpy(Calloc(ntot, double), b, ntot); if (nc == 1) { sumsq = delb[0] * delb[0]; for (i = 0; i < nlev; i++) b[i] += delb[0] * bVfac[i]; } else { int ncsq = nc * nc; double *tmp = Calloc(nc, double); for (i = 0; i < nlev; i++) { Memcpy(tmp, delb, nc); F77_CALL(dtrmv)("U", "N", "N", &nc, &(bVfac[i * ncsq]), &nc, tmp, &ione); for (j = 0; j < nc; j++) b[i + j * nc] = tmp[j]; } /* sum of squares of delb */ for (j = 0; j < nc; j++) sumsq += delb[j] * delb[j]; } for (i = 0; i < nlev; i++) devcmp[i] = -sumsq; } internal_mer_fitted(GS->mer, GS->offset, REAL(GS->eta)); eval_check_store(GS->linkinv, GS->rho, GS->mu); devs = PROTECT(eval_check(GS->dev_resids, GS->rho, REALSXP, GS->n)); for (i = 0; i < GS->n; i++) devcmp[fv[i] - 1] += REAL(devs)[i]; UNPROTECT(1); if (nc == 1) { for (i = 0; i < nlev; i++) { double tmp = *OmgFac * b[i]; devcmp[i] += tmp * tmp; } } else { double *tmp = Calloc(nc, double); int ione = 1; for (i = 0; i < nlev; i++) { for (j = 0; j < nc; j++) tmp[j] = b[i + j * nlev]; F77_CALL(dtrmv)("U", "N", "N", &nc, OmgFac, &nc, tmp, &ione); for (j = 0; j < nc; j++) devcmp[i] += tmp[j] * tmp[j]; } } if (delb) { Memcpy(b, bcp, ntot); Free(bcp); } return devcmp; }