static void weightDenseComponents(SEXP regression, MERCache* cache) { const int* dims = DIMS_SLOT(regression); int numObservations = dims[n_POS]; int numUnmodeledCoefs = dims[p_POS]; double* sqrtObservationWeight = SXWT_SLOT(regression); double* offsets = OFFSET_SLOT(regression); const double* denseDesignMatrix = X_SLOT(regression); double* weightedDenseDesignMatrix = cache->weightedDenseDesignMatrix; const double* response = Y_SLOT(regression); double* weightedResponse = cache->weightedResponse; cache->responseSumOfSquares = 0.0; for (int row = 0; row < numObservations; ++row) { double rowWeight = (sqrtObservationWeight ? sqrtObservationWeight[row] : 1.0); for (int col = 0; col < numUnmodeledCoefs; ++col) { int matrixIndex = row + col * numObservations; weightedDenseDesignMatrix[matrixIndex] = denseDesignMatrix[matrixIndex] * rowWeight; } weightedResponse[row] = (response[row] - (offsets ? offsets[row] : 0.0)) * rowWeight; cache->responseSumOfSquares += weightedResponse[row] * weightedResponse[row]; } }
static void cpglm_fitted(double *x, SEXP da){ int *dm = DIMS_SLOT(da) ; int nO = dm[nO_POS], nB = dm[nB_POS]; double *X = X_SLOT(da), *beta = FIXEF_SLOT(da), *eta = ETA_SLOT(da), *mu = MU_SLOT(da), *offset = OFFSET_SLOT(da), lp = LKP_SLOT(da)[0] ; if (x) beta = x ; /* point beta to x if x is not NULL */ /* eta = X %*% beta */ mult_mv("N", nO, nB, X, beta, eta) ; for (int i = 0; i < nO; i++){ eta[i] += offset[i] ; mu[i] = link_inv(eta[i], lp); } }
/** * Update the Xb, Zu, eta and mu slots in cpglmm according to x * * @param x pointer to the vector of values for beta or u * @param is_beta indicates whether x contains the values for beta or u. * 1: x contains values of beta, and Zu is not updated. If x is null, the fixef slot is used; * 0: x contains values of u, and Xb is not updated. If x is null, the u slot is used; * -1: x is ignored, and the fixef and u slots are used. * @param da an SEXP object * */ static void cpglmm_fitted(double *x, int is_beta, SEXP da){ int *dm = DIMS_SLOT(da) ; int nO = dm[nO_POS], nB = dm[nB_POS], nU = dm[nU_POS]; double *X = X_SLOT(da), *eta = ETA_SLOT(da), *mu = MU_SLOT(da), *beta = FIXEF_SLOT(da), *u = U_SLOT(da), *offset= OFFSET_SLOT(da), *Xb = XB_SLOT(da), *Zu = ZU_SLOT(da), lp = LKP_SLOT(da)[0], one[] = {1, 0}, zero[] = {0, 0}; if (is_beta == -1) x = NULL ; /* update from the fixef and u slots */ /* update Xb */ if (is_beta == 1 || is_beta == -1){ /* beta is updated */ if (x) beta = x ; /* point beta to x if x is not NULL */ mult_mv("N", nO, nB, X, beta, Xb) ; /* Xb = x * beta */ } /* update Zu */ if (is_beta == 0 || is_beta == -1){ /* u is updated */ SEXP tmp; /* create an SEXP object to be coerced to CHM_DN */ PROTECT(tmp = allocVector(REALSXP, nU)); if (x) Memcpy(REAL(tmp), x, nU); else Memcpy(REAL(tmp), u, nU); CHM_DN ceta, us = AS_CHM_DN(tmp); CHM_SP Zt = Zt_SLOT(da); R_CheckStack(); ceta = N_AS_CHM_DN(Zu, nO, 1); /* update Zu */ R_CheckStack(); /* Y = alpha * A * X + beta * Y */ if (!M_cholmod_sdmult(Zt, 1 , one, zero, us, ceta, &c)) error(_("cholmod_sdmult error returned")); UNPROTECT(1) ; } for (int i = 0; i < nO; i++){ /* update mu */ eta[i] = Xb[i] + Zu[i] + offset[i]; /* eta = Xb + Z * u + offset*/ mu[i] = link_inv(eta[i], lp); } }
/** * Update the theta_S parameters from the ST arrays in place. * * @param x an mer object * @param sigma current standard deviation of the per-observation * noise terms. */ static void MCMC_S(SEXP x, double sigma) { CHM_SP A = A_SLOT(x), Zt = Zt_SLOT(x); int *Gp = Gp_SLOT(x), *ai = (int*)(A->i), *ap = (int*)(A->p), *dims = DIMS_SLOT(x), *perm = PERM_VEC(x); int annz = ap[A->ncol], info, i1 = 1, n = dims[n_POS], nt = dims[nt_POS], ns, p = dims[p_POS], pos, q = dims[q_POS], znnz = ((int*)(Zt->p))[Zt->ncol]; double *R, *ax = (double*)(A->x), *b = RANEF_SLOT(x), *eta = ETA_SLOT(x), *offset = OFFSET_SLOT(x), *rr, *ss, one = 1, *u = U_SLOT(x), *y = Y_SLOT(x); int *nc = Alloca(nt, int), *nlev = Alloca(nt, int), *spt = Alloca(nt + 1, int); double **st = Alloca(nt, double*); R_CheckStack(); ST_nc_nlev(GET_SLOT(x, lme4_STSym), Gp, st, nc, nlev); ns = 0; /* ns is length(theta_S) */ spt[0] = 0; /* pointers into ss for terms */ for (int i = 0; i < nt; i++) { ns += nc[i]; spt[i + 1] = spt[i] + nc[i]; } if (annz == znnz) { /* Copy Z' to A unless A has new nonzeros */ Memcpy(ax, (double*)(Zt->x), znnz); } else error("Code not yet written for MCMC_S with NLMMs"); /* Create T'Zt in A */ Tt_Zt(A, Gp, nc, nlev, st, nt); /* Create P'u in ranef slot */ for (int i = 0; i < q; i++) b[perm[i]] = u[i]; /* Create X\beta + offset in eta slot */ for (int i = 0; i < n; i++) eta[i] = offset ? offset[i] : 0; F77_CALL(dgemv)("N", &n, &p, &one, X_SLOT(x), &n, FIXEF_SLOT(x), &i1, &one, eta, &i1); /* Allocate R, rr and ss */ R = Alloca(ns * ns, double); /* crossproduct matrix then factor */ rr = Alloca(ns, double); /* row of model matrix for theta_S */ ss = Alloca(ns, double); /* right hand side, then theta_S */ R_CheckStack(); AZERO(R, ns * ns); AZERO(ss, ns); /* Accumulate crossproduct from pseudo-data part of model matrix */ for (int i = 0; i < q; i++) { int sj = theta_S_ind(i, nt, Gp, nlev, spt); AZERO(rr, ns); rr[sj] = b[i]; F77_CALL(dsyr)("U", &ns, &one, rr, &i1, R, &ns); } /* Accumulate crossproduct and residual product of the model matrix. */ /* This is done one row at a time. Rows of the model matrix * correspond to columns of T'Zt */ for (int j = 0; j < n; j++) { /* jth column of T'Zt */ AZERO(rr, ns); for (int p = ap[j]; p < ap[j + 1]; p++) { int i = ai[p]; /* row in T'Zt */ int sj = theta_S_ind(i, nt, Gp, nlev, spt); rr[sj] += ax[p] * b[i]; ss[sj] += rr[sj] * (y[j] - eta[j]); } F77_CALL(dsyr)("U", &ns, &one, rr, &i1, R, &ns); } F77_CALL(dposv)("U", &ns, &i1, R, &ns, ss, &ns, &info); if (info) error(_("Model matrix for theta_S is not positive definite, %d."), info); for (int j = 0; j < ns; j++) rr[j] = sigma * norm_rand(); /* Sample from the conditional Gaussian distribution */ F77_CALL(dtrsv)("U", "N", "N", &ns, R, &ns, rr, &i1); for (int j = 0; j < ns; j++) ss[j] += rr[j]; /* Copy positive part of solution onto diagonals of ST */ pos = 0; for (int i = 0; i < nt; i++) { for (int j = 0; j < nc[i]; j++) { st[i][j * (nc[i] + 1)] = (ss[pos] > 0) ? ss[pos] : 0; pos++; } } update_A(x); }