/**
* 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;
}
SEXP port_nlsb(SEXP m, SEXP d, SEXP gg, SEXP iv, SEXP v,
SEXP lowerb, SEXP upperb)
{
int *dims = INTEGER(getAttrib(gg, R_DimSymbol));
int i, n = LENGTH(d), p = LENGTH(d), nd = dims[0];
SEXP getPars, setPars, resid, gradient,
rr = PROTECT(allocVector(REALSXP, nd)),
x = PROTECT(allocVector(REALSXP, n));
// This used to use Calloc, but that will leak if
// there is a premature return (and did in package drfit)
double *b = (double *) NULL,
*rd = (double *)R_alloc(nd, sizeof(double));
if (!isReal(d) || n < 1)
error(_("'d' must be a nonempty numeric vector"));
if(!isNewList(m)) error(_("m must be a list"));
/* Initialize parameter vector */
getPars = PROTECT(lang1(getFunc(m, "getPars", "m")));
eval_check_store(getPars, R_GlobalEnv, x);
/* Create the setPars call */
setPars = PROTECT(lang2(getFunc(m, "setPars", "m"), x));
/* Evaluate residual and gradient */
resid = PROTECT(lang1(getFunc(m, "resid", "m")));
eval_check_store(resid, R_GlobalEnv, rr);
gradient = PROTECT(lang1(getFunc(m, "gradient", "m")));
neggrad(gradient, R_GlobalEnv, gg);
if ((LENGTH(lowerb) == n) && (LENGTH(upperb) == n)) {
if (isReal(lowerb) && isReal(upperb)) {
double *rl = REAL(lowerb), *ru = REAL(upperb);
b = (double *)R_alloc(2*n, sizeof(double));
for (i = 0; i < n; i++) {
b[2*i] = rl[i];
b[2*i + 1] = ru[i];
}
} else error(_("'lowerb' and 'upperb' must be numeric vectors"));
}
do {
nlsb_iterate(b, REAL(d), REAL(gg), INTEGER(iv), LENGTH(iv),
LENGTH(v), n, nd, p, REAL(rr), rd,
REAL(v), REAL(x));
switch(INTEGER(iv)[0]) {
case -3:
eval(setPars, R_GlobalEnv);
eval_check_store(resid, R_GlobalEnv, rr);
neggrad(gradient, R_GlobalEnv, gg);
break;
case -2:
eval_check_store(resid, R_GlobalEnv, rr);
neggrad(gradient, R_GlobalEnv, gg);
break;
case -1:
eval(setPars, R_GlobalEnv);
eval_check_store(resid, R_GlobalEnv, rr);
neggrad(gradient, R_GlobalEnv, gg);
break;
case 0:
Rprintf("nlsb_iterate returned %d", INTEGER(iv)[0]);
break;
case 1:
eval(setPars, R_GlobalEnv);
eval_check_store(resid, R_GlobalEnv, rr);
break;
case 2:
eval(setPars, R_GlobalEnv);
neggrad(gradient, R_GlobalEnv, gg);
break;
}
} while(INTEGER(iv)[0] < 3);
UNPROTECT(6);
return R_NilValue;
}
/**
* 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;
}
