SEXP d2q(SEXP foo)
{
if (! isReal(foo))
error("argument must be real");
int n = LENGTH(foo);
int i;
for (i = 0; i < n; i++)
if (! R_finite(REAL(foo)[i]))
error("argument not finite-valued");
SEXP bar, bark;
PROTECT(bar = allocVector(STRSXP, n));
PROTECT(bark = ATTRIB(foo));
if (bark != R_NilValue)
SET_ATTRIB(bar, duplicate(bark));
UNPROTECT(1);
mpq_t value;
mpq_init(value);
int k;
for (k = 0; k < n; k++) {
double z = REAL(foo)[k];
mpq_set_d(value, z);
char *zstr = NULL;
zstr = mpq_get_str(zstr, 10, value);
SET_STRING_ELT(bar, k, mkChar(zstr));
free(zstr);
}
mpq_clear(value);
UNPROTECT(1);
return(bar);
}
int find_offset(SEXP x, SEXP index, int i) {
if (!Rf_isVector(index) || Rf_length(index) != 1)
Rf_errorcall(R_NilValue, "Index %i is not a length 1 vector", i + 1);
int n = Rf_length(x);
if (TYPEOF(index) == INTSXP) {
int val = INTEGER(index)[0];
if (val == NA_INTEGER)
return -1;
val--;
if (val < 0 || val >= n)
return -1;
return val;
} if (TYPEOF(index) == REALSXP) {
double val = REAL(index)[0];
if (!R_finite(val))
return -1;
val--;
if (val < 0 || val >= n)
return -1;
return val;
} else if (TYPEOF(index) == STRSXP) {
SEXP names = Rf_getAttrib(x, R_NamesSymbol);
if (names == R_NilValue) // vector doesn't have names
return -1;
if (STRING_ELT(index, 0) == NA_STRING)
return -1;
const char* val = Rf_translateCharUTF8(STRING_ELT(index, 0));
if (val[0] == '\0') // "" matches nothing
return -1;
for (int j = 0; j < Rf_length(names); ++j) {
if (STRING_ELT(names, j) == NA_STRING)
continue;
const char* names_j = Rf_translateCharUTF8(STRING_ELT(names, j));
if (strcmp(names_j, val) == 0)
return j;
}
return -1;
} else {
Rf_errorcall(R_NilValue,
"Don't know how to index with object of type %s at level %i",
Rf_type2char(TYPEOF(index)), i + 1
);
}
}
double pwiener_full_d(double q, double alpha, double tau, double beta, double delta)
{
double p;
if (q < 0) return R_NaN;
if(!R_finite(q)) return R_PosInf; // infinity
p = pwiener_d(q, alpha,tau,beta,delta);
p += pwiener_d(-q, alpha,tau,beta,delta);
return p;
}
double lqd2(double **SresRaw, long nobs, long nvars_unique, long ncats)
{
double fit_lqd2, *rawres, *dif;
long h, diflen, hidx, total_obs, i, ii, j, k, count;
total_obs = nobs*(ncats-1);
h = (long) (total_obs+nvars_unique+1)/2;
diflen = (total_obs*(total_obs-1))/2;
hidx = (h*(h-1))/2;
rawres = (double *) calloc(total_obs, sizeof(double));
dif = (double *) calloc(diflen,sizeof(double));
count = 0;
for (i=0; i<nobs; i++)
{
for (j=0; j<(ncats-1); j++)
{
rawres[count] = SresRaw[i][j];
//Rprintf("rawres[%d] %lf, SresRaw[%d][%d]: %lf\n", count, rawres[count], i, j, SresRaw[i][j]);
count++;
} // end of j
} // end of i
for (i=2; i<=total_obs; i++)
{
ii = ((i-1)*(i-2))/2;
for(j=1; j<=(i-1); j++)
{
k = ii+j;
dif[k-1] = fabs(rawres[i-1]-rawres[j-1]);
}
} // end of i
/*
qsort(dif, diflen, sizeof(double), (int (*)(const void *, const void *)) bcacmp);
fit_lqd2 = dif[hidx-1] * 2.21914446599;
*/
fit_lqd2 = kth_smallest(dif, diflen, hidx-1) * 2.21914446599;
if (!R_finite(fit_lqd2))
{
/* Rprintf("XXX\n"); */
fit_lqd2 = 999991234;
}
//free memory
free(dif);
free(rawres);
return(fit_lqd2);
} // end of lqd2
bool
MatrixLT<dataType>::is_finite() const
{
const dataType *a;
for (int i = 0; i < _length; i++){
if (!R_finite(*a)) return false;
a++;
}
return true;
}
SEXP all_finite(SEXP x){
PROTECT(x);
double *X = REAL(x);
idx l = (idx) length(x);
int ans = 1;
for ( idx i = 0; i<l; i++, X++){
if ( !R_finite(*X) ){
ans = 0;
break;
}
}
UNPROTECT(1);
return mklgl(ans);
}
Rcpp::List reTrms::condVar(double scale) {
if (scale < 0 || !R_finite(scale))
throw runtime_error("scale must be non-negative and finite");
int nf = d_flist.size();
IntegerVector nc = ncols(), nl = nlevs(), nct = nctot(), off = offsets();
List ans(nf);
CharacterVector nms = d_flist.names();
ans.names() = clone(nms);
for (int i = 0; i < nf; i++) {
int ncti = nct[i], nli = nl[i];
IntegerVector trms = terms(i);
int *cset = new int[ncti], nct2 = ncti * ncti;
NumericVector ansi(Dimension(ncti, ncti, nli));
ans[i] = ansi;
double *ai = ansi.begin();
for (int j = 0; j < nli; j++) {
int kk = 0;
for (int jj = 0; jj < trms.size(); jj++) {
int tjj = trms[jj];
for (int k = 0; k < nc[tjj]; k++)
cset[kk++] = off[tjj] + j * nc[tjj] + k;
}
CHM_SP cols =
M_cholmod_submatrix(&d_Lambda, (int*)NULL, -1, cset, ncti,
1/*values*/, 1/*sorted*/, &c);
CHM_SP sol = d_L.spsolve(CHOLMOD_A, cols);
CHM_SP tcols = M_cholmod_transpose(cols, 1/*values*/, &c);
M_cholmod_free_sparse(&cols, &c);
CHM_SP var = M_cholmod_ssmult(tcols, sol, 0/*stype*/,
1/*values*/, 1/*sorted*/, &c);
M_cholmod_free_sparse(&sol, &c);
M_cholmod_free_sparse(&tcols, &c);
CHM_DN dvar = M_cholmod_sparse_to_dense(var, &c);
M_cholmod_free_sparse(&var, &c);
Memcpy(ai + j * nct2, (double*)dvar->x, nct2);
M_cholmod_free_dense(&dvar, &c);
}
delete[] cset;
transform(ansi.begin(), ansi.end(), ansi.begin(),
bind2nd(multiplies<double>(), scale * scale));
}
return ans;
}
double pwiener_d(double q, double alpha, double tau, double beta, double delta)
{
double p;
if(!R_finite(q)) return R_PosInf;
if (R_IsNaN(q)) return R_NaN;
if (fabs(q) <= tau) return 0;
if (q < 0) { // lower boundary 0
p = F_lower(fabs(q)-tau, delta, alpha, beta);
}
else { // upper boundary a
p = F_lower(q-tau, (-delta), alpha, (1-beta));
}
return p;
}
SEXP baz(SEXP x)
{
if (! isReal(x))
error("'x' must be type double");
int n = LENGTH(x);
for (int i = 0; i < n; i++)
if (! R_finite(REAL(x)[i]))
error("'x' must be all finite-valued");
SEXP result;
PROTECT(result = allocVector(REALSXP, n));
for (int i = 0; i < n; i++) {
double foo = REAL(x)[i];
REAL(result)[i] = foo * foo;
}
UNPROTECT(1);
return result;
}
// interface to R's is.finite variant (C99) that takes care of NA representation.
SEXP all_finite_double(SEXP x){
PROTECT(x);
double *xx = REAL(x);
SEXP y;
PROTECT(y = allocVector(LGLSXP,1));
int i, b = 1;
for (i=0; i<length(x); i++) {
b = R_finite(xx[i]);
if (!b) break;
}
LOGICAL(y)[0] = b;
UNPROTECT(2);
return y;
}
bool isFinite(Type x){
return R_finite(asDouble(x));
}
SEXP scdd_f(SEXP m, SEXP h, SEXP roworder, SEXP adjacency,
SEXP inputadjacency, SEXP incidence, SEXP inputincidence)
{
int i, j, k;
GetRNGstate();
if (! isMatrix(m))
error("'m' must be matrix");
if (! isLogical(h))
error("'h' must be logical");
if (! isString(roworder))
error("'roworder' must be character");
if (! isLogical(adjacency))
error("'adjacency' must be logical");
if (! isLogical(inputadjacency))
error("'inputadjacency' must be logical");
if (! isLogical(incidence))
error("'incidence' must be logical");
if (! isLogical(inputincidence))
error("'inputincidence' must be logical");
if (LENGTH(h) != 1)
error("'h' must be scalar");
if (LENGTH(roworder) != 1)
error("'roworder' must be scalar");
if (LENGTH(adjacency) != 1)
error("'adjacency' must be scalar");
if (LENGTH(inputadjacency) != 1)
error("'inputadjacency' must be scalar");
if (LENGTH(incidence) != 1)
error("'incidence' must be scalar");
if (LENGTH(inputincidence) != 1)
error("'inputincidence' must be scalar");
if (! isReal(m))
error("'m' must be double");
SEXP m_dim;
PROTECT(m_dim = getAttrib(m, R_DimSymbol));
int nrow = INTEGER(m_dim)[0];
int ncol = INTEGER(m_dim)[1];
UNPROTECT(1);
#ifdef BLATHER
printf("nrow = %d\n", nrow);
printf("ncol = %d\n", ncol);
#endif /* BLATHER */
if ((! LOGICAL(h)[0]) && nrow <= 0)
error("no rows in 'm', not allowed for V-representation");
if (ncol <= 2)
error("no cols in m[ , - c(1, 2)]");
for (i = 0; i < nrow * ncol; i++)
if (! R_finite(REAL(m)[i]))
error("'m' not finite-valued");
for (i = 0; i < nrow; i++) {
double foo = REAL(m)[i];
if (! (foo == 0.0 || foo == 1.0))
error("column one of 'm' not zero-or-one valued");
}
if (! LOGICAL(h)[0])
for (i = nrow; i < 2 * nrow; i++) {
double foo = REAL(m)[i];
if (! (foo == 0.0 || foo == 1.0))
error("column two of 'm' not zero-or-one valued");
}
ddf_set_global_constants();
myfloat value;
ddf_init(value);
ddf_MatrixPtr mf = ddf_CreateMatrix(nrow, ncol - 1);
/* note our matrix has one more column than Fukuda's */
/* representation */
if(LOGICAL(h)[0])
mf->representation = ddf_Inequality;
else
mf->representation = ddf_Generator;
mf->numbtype = ddf_Real;
/* linearity */
for (i = 0; i < nrow; i++) {
double foo = REAL(m)[i];
if (foo == 1.0)
set_addelem(mf->linset, i + 1);
/* note conversion from zero-origin to one-origin indexing */
}
/* matrix */
for (j = 1, k = nrow; j < ncol; j++)
for (i = 0; i < nrow; i++, k++) {
ddf_set_d(value, REAL(m)[k]);
ddf_set(mf->matrix[i][j - 1], value);
/* note our matrix has one more column than Fukuda's */
}
ddf_RowOrderType strategy = ddf_LexMin;
const char *row_str = CHAR(STRING_ELT(roworder, 0));
if(strcmp(row_str, "maxindex") == 0)
strategy = ddf_MaxIndex;
else if(strcmp(row_str, "minindex") == 0)
strategy = ddf_MinIndex;
else if(strcmp(row_str, "mincutoff") == 0)
strategy = ddf_MinCutoff;
else if(strcmp(row_str, "maxcutoff") == 0)
strategy = ddf_MaxCutoff;
else if(strcmp(row_str, "mixcutoff") == 0)
strategy = ddf_MixCutoff;
else if(strcmp(row_str, "lexmin") == 0)
strategy = ddf_LexMin;
else if(strcmp(row_str, "lexmax") == 0)
strategy = ddf_LexMax;
else if(strcmp(row_str, "randomrow") == 0)
strategy = ddf_RandomRow;
else
error("roworder not recognized");
ddf_ErrorType err = ddf_NoError;
ddf_PolyhedraPtr poly = ddf_DDMatrix2Poly2(mf, strategy, &err);
if (poly->child != NULL && poly->child->CompStatus == ddf_InProgress) {
ddf_FreeMatrix(mf);
ddf_FreePolyhedra(poly);
ddf_clear(value);
ddf_free_global_constants();
error("Computation failed, floating-point arithmetic problem\n");
}
if (err != ddf_NoError) {
rrf_WriteErrorMessages(err);
ddf_FreeMatrix(mf);
ddf_FreePolyhedra(poly);
ddf_clear(value);
ddf_free_global_constants();
error("failed");
}
ddf_MatrixPtr aout = NULL;
if (poly->representation == ddf_Inequality)
aout = ddf_CopyGenerators(poly);
else if (poly->representation == ddf_Generator)
aout = ddf_CopyInequalities(poly);
else
error("Cannot happen! poly->representation no good\n");
if (aout == NULL)
error("Cannot happen! aout no good\n");
int mrow = aout->rowsize;
int mcol = aout->colsize;
if (mcol + 1 != ncol)
error("Cannot happen! computed matrix has wrong number of columns");
#ifdef BLATHER
printf("mrow = %d\n", mrow);
printf("mcol = %d\n", mcol);
#endif /* BLATHER */
SEXP bar;
PROTECT(bar = allocMatrix(REALSXP, mrow, ncol));
/* linearity output */
for (i = 0; i < mrow; i++)
if (set_member(i + 1, aout->linset))
REAL(bar)[i] = 1.0;
else
REAL(bar)[i] = 0.0;
/* note conversion from zero-origin to one-origin indexing */
/* matrix output */
for (j = 1, k = mrow; j < ncol; j++)
for (i = 0; i < mrow; i++, k++) {
double ax = ddf_get_d(aout->matrix[i][j - 1]);
/* note our matrix has one more column than Fukuda's */
REAL(bar)[k] = ax;
}
int nresult = 1;
SEXP baz_adj = NULL;
if (LOGICAL(adjacency)[0]) {
ddf_SetFamilyPtr sout = ddf_CopyAdjacency(poly);
PROTECT(baz_adj = rrf_WriteSetFamily(sout));
ddf_FreeSetFamily(sout);
nresult++;
}
SEXP baz_inp_adj = NULL;
if (LOGICAL(inputadjacency)[0]) {
ddf_SetFamilyPtr sout = ddf_CopyInputAdjacency(poly);
PROTECT(baz_inp_adj = rrf_WriteSetFamily(sout));
ddf_FreeSetFamily(sout);
nresult++;
}
SEXP baz_inc = NULL;
if (LOGICAL(incidence)[0]) {
ddf_SetFamilyPtr sout = ddf_CopyIncidence(poly);
PROTECT(baz_inc = rrf_WriteSetFamily(sout));
ddf_FreeSetFamily(sout);
nresult++;
}
SEXP baz_inp_inc = NULL;
if (LOGICAL(inputincidence)[0]) {
ddf_SetFamilyPtr sout = ddf_CopyInputIncidence(poly);
PROTECT(baz_inp_inc = rrf_WriteSetFamily(sout));
ddf_FreeSetFamily(sout);
nresult++;
}
SEXP result, resultnames;
PROTECT(result = allocVector(VECSXP, nresult));
PROTECT(resultnames = allocVector(STRSXP, nresult));
SET_STRING_ELT(resultnames, 0, mkChar("output"));
SET_VECTOR_ELT(result, 0, bar);
int iresult = 1;
if (baz_adj) {
SET_STRING_ELT(resultnames, iresult, mkChar("adjacency"));
SET_VECTOR_ELT(result, iresult, baz_adj);
iresult++;
}
if (baz_inp_adj) {
SET_STRING_ELT(resultnames, iresult, mkChar("inputadjacency"));
SET_VECTOR_ELT(result, iresult, baz_inp_adj);
iresult++;
}
if (baz_inc) {
SET_STRING_ELT(resultnames, iresult, mkChar("incidence"));
SET_VECTOR_ELT(result, iresult, baz_inc);
iresult++;
}
if (baz_inp_inc) {
SET_STRING_ELT(resultnames, iresult, mkChar("inputincidence"));
SET_VECTOR_ELT(result, iresult, baz_inp_inc);
iresult++;
}
namesgets(result, resultnames);
if (aout->objective != ddf_LPnone)
error("Cannot happen! aout->objective != ddf_LPnone\n");
ddf_FreeMatrix(aout);
ddf_FreeMatrix(mf);
ddf_FreePolyhedra(poly);
ddf_clear(value);
ddf_free_global_constants();
UNPROTECT(2 + nresult);
PutRNGstate();
return result;
}
SEXP impliedLinearity_f(SEXP m, SEXP h)
{
GetRNGstate();
if (! isMatrix(m))
error("'m' must be matrix");
if (! isLogical(h))
error("'h' must be logical");
if (LENGTH(h) != 1)
error("'h' must be scalar");
if (! isReal(m))
error("'m' must be double");
SEXP m_dim;
PROTECT(m_dim = getAttrib(m, R_DimSymbol));
int nrow = INTEGER(m_dim)[0];
int ncol = INTEGER(m_dim)[1];
UNPROTECT(1);
if (nrow <= 1)
error("no use if only one row");
if (ncol <= 3)
error("no use if only one col");
for (int i = 0; i < nrow * ncol; i++)
if (! R_finite(REAL(m)[i]))
error("'m' not finite-valued");
for (int i = 0; i < nrow; i++) {
double foo = REAL(m)[i];
if (! (foo == 0.0 || foo == 1.0))
error("column one of 'm' not zero-or-one valued");
}
if (! LOGICAL(h)[0])
for (int i = nrow; i < 2 * nrow; i++) {
double foo = REAL(m)[i];
if (! (foo == 0.0 || foo == 1.0))
error("column two of 'm' not zero-or-one valued");
}
ddf_set_global_constants();
myfloat value;
ddf_init(value);
ddf_MatrixPtr mf = ddf_CreateMatrix(nrow, ncol - 1);
/* note our matrix has one more column than Fukuda's */
/* representation */
if(LOGICAL(h)[0])
mf->representation = ddf_Inequality;
else
mf->representation = ddf_Generator;
mf->numbtype = ddf_Real;
/* linearity */
for (int i = 0; i < nrow; i++) {
double foo = REAL(m)[i];
if (foo == 1.0)
set_addelem(mf->linset, i + 1);
/* note conversion from zero-origin to one-origin indexing */
}
/* matrix */
for (int j = 1, k = nrow; j < ncol; j++)
for (int i = 0; i < nrow; i++, k++) {
ddf_set_d(value, REAL(m)[k]);
ddf_set(mf->matrix[i][j - 1], value);
/* note our matrix has one more column than Fukuda's */
}
ddf_ErrorType err = ddf_NoError;
ddf_rowset out = ddf_ImplicitLinearityRows(mf, &err);
if (err != ddf_NoError) {
rrf_WriteErrorMessages(err);
ddf_FreeMatrix(mf);
set_free(out);
ddf_clear(value);
ddf_free_global_constants();
error("failed");
}
SEXP foo;
PROTECT(foo = rrf_set_fwrite(out));
ddf_FreeMatrix(mf);
set_free(out);
ddf_clear(value);
ddf_free_global_constants();
PutRNGstate();
UNPROTECT(1);
return foo;
}
/***** ***************************************************************************************** *****/
void
loglik_Zwork1(double* loglik,
double* b,
double* Zwork1,
double* sqrt_w_phi,
int* err,
double** eta_fixedresp, // this is in fact const
double** dYresp, // this is in fact const
double** Y_cresp, // this is in fact const
int** Y_dresp, // this is in fact const
int** nresp, // this is in fact const
double** Zresp, // this is in fact const
const double* bscaled,
const double* ZS,
const double* sigma,
const double* shift_b,
const double* scale_b,
const int* q,
const int* randIntcpt,
const int* q_ri,
const int* dist,
const int* R_c,
const int* R_d)
{
const char *fname = "MCMC::loglik_Zwork1 (PROTOTYPE 2)";
static int s, s2, l, j;
static const int *dist_s, *q_ri_s, *q_s, *randIntcpt_s;
static double *Zwork1_s, *sqrt_w_phi_s, *sqrt_w_phiP;
static double *b_s, *bP;
static const double *sigma_s;
static const double *bscaled_s, *shift_b_s, *scale_b_s;
static const double *ZSP;
static double loglik_s;
ZSP = ZS;
q_s = q;
randIntcpt_s = randIntcpt;
q_ri_s = q_ri;
dist_s = dist;
*loglik = 0.0;
Zwork1_s = Zwork1;
sqrt_w_phi_s = sqrt_w_phi;
bscaled_s = bscaled;
shift_b_s = shift_b;
scale_b_s = scale_b;
b_s = b;
sigma_s = sigma;
for (s = 0; s < *R_c + *R_d; s++){ /*** loop over response profiles ***/
/*** Calculate b ***/
bP = b_s;
for (l = 0; l < *q_ri_s; l++){
*bP = *shift_b_s + *scale_b_s * *bscaled_s;
bscaled_s++;
shift_b_s++;
scale_b_s++;
bP++;
}
/*** Calculate the current value of the (conditional) log-likelihood value ***/
/*** Fill-in sqrt_w_phi_s ***/
switch (*dist_s){
case GLMM::GAUSS_IDENTITY:
LogLik::Gauss_Identity_sqrt_w_phi1(&loglik_s, sqrt_w_phi_s,
eta_fixedresp[s], b_s, sigma_s, Y_cresp[s], NULL, Zresp[s], nresp[s], q_s, randIntcpt_s);
sigma_s++;
break;
case GLMM::BERNOULLI_LOGIT:
LogLik::Bernoulli_Logit_sqrt_w_phi1(&loglik_s, sqrt_w_phi_s,
eta_fixedresp[s], b_s, NULL, Y_dresp[s - *R_c], dYresp[s], Zresp[s], nresp[s], q_s, randIntcpt_s);
break;
case GLMM::POISSON_LOG:
LogLik::Poisson_Log_sqrt_w_phi1(&loglik_s, sqrt_w_phi_s,
eta_fixedresp[s], b_s, NULL, Y_dresp[s - *R_c], dYresp[s], Zresp[s], nresp[s], q_s, randIntcpt_s);
break;
default:
*err = 1;
error("%s: Unimplemented distributional type (%d).\n", fname, *dist_s);
}
if (!R_finite(loglik_s)){
*err = 1;
return;
//error("%s: TRAP, infinite log-likelihood for response profile %d.\n", fname, s + 1);
}
*loglik += loglik_s;
/*** Fill-in Zwork1 ***/
for (l = 0; l < *q_ri_s; l++){ /*** loop over columns of Zwork1 ***/
s2 = 0;
/*** Block of zeros above Zwork1[s, s] block ***/
while (s2 < s){
for (j = 0; j < *nresp[s2]; j++){
*Zwork1_s = 0.0;
Zwork1_s++;
}
s2++;
}
/*** Non-zero block Zwork1[s, s] ***/
sqrt_w_phiP = sqrt_w_phi_s;
for (j = 0; j < *nresp[s2]; j++){
*Zwork1_s = *sqrt_w_phiP * *ZSP;
Zwork1_s++;
sqrt_w_phiP++;
ZSP++; /*** shift ZSP ***/
}
s2++;
/*** Block of zeros below Zwork1[s, s] ***/
while (s2 < *R_c + *R_d){
for (j = 0; j < *nresp[s2]; j++){
*Zwork1_s = 0.0;
Zwork1_s++;
}
s2++;
}
} /*** end of loop over columns of Zwork1 ***/
b_s += *q_ri_s;
sqrt_w_phi_s += *nresp[s];
q_s++;
randIntcpt_s++;
q_ri_s++;
dist_s++;
} /*** end of loop over response profiles ***/
return;
}
/***** ***************************************************************************************** *****/
void
updateRanEf(double* b,
double* bscaled,
double** eta_randomresp,
double** etaresp,
double** meanYresp,
double* log_dets_full,
double* dwork,
double** Y_crespP,
int** Y_drespP,
double** dYrespP,
double** eta_fixedrespP,
double** eta_randomrespP,
double** eta_zsrespP,
double** etarespP,
double** meanYrespP,
double** ZrespP,
int** nrespP,
int* naccept,
int* err,
double** Y_cresp, // this is in fact const
int** Y_dresp, // this is in fact const
double** dYresp, // this is in fact const
double** eta_fixedresp, // this is in fact const
double** eta_zsresp, // this is in fact const
double** Zresp, // this is in fact const
const double* SZitZiS,
const double* shift,
const double* scale,
const int* q,
const int* randIntcpt,
const int* q_ri,
const int* cumq_ri,
const int* dim_b,
const int* LT_b,
const int* R_c,
const int* R_d,
const int* dist,
const int* I,
int** nresp, // this is in fact const
const int* N_i,
const double* sigma,
const int* K,
const double* mu,
const double* Q,
const double* Li,
const double* log_dets,
const int* r,
const double* sqrt_tune_scale,
const double* log_sqrt_tune_scale)
{
const char *fname = "GLMM::updateRanEf";
static int s, i, j, k, itmp, row, col;
static int accept;
static double resid;
static double log_prop_ratio, loglik, loglik_prop, logprior, logprior_prop, logq, logq_prop;
static double loglik_s;
static double *bP, *bscaledP, *bscaled_i, *b_i, *eta_random_propP, *mean_Y_d_propP, *Li_full_backupP, *Li_fullP;
static double *mu_fullP, *mu_full_resp, *Li_full_resp, *mu_full2_resp, *Li_full2_resp;
static double *bscaled_resp, *b_resp;
static int *naccept_i;
static double *Y_cP, *eta_fixedP, *eta_zsP, *zP; /** these are in fact const **/
static const double *SZitZiS_i, *SZitZiS_resp;
static const double *shift_resp, *scale_resp;
static const double *sigma_resp;
static const int *qP, *randIntcptP, *q_riP, *cumq_riP, *N_iP, *distP;
static double *Qmu_resp, *Qmu_i;
static const double *mu_resp, *Q_i, *Li_i, *mu_i, *log_dets_i;
static const int *r_i;
static const double *ImatP;
/*** Parts of dwork ***/
/*** ============== ***/
static double *Qmu, *dwork_MVN, *mu_full, *mu_full2, *Li_full, *Li_full2, *Imat, *bscaled_prop, *b_prop, *Li_full_backup, *eta_random_prop, *mean_Y_d_prop;
Qmu = dwork;
dwork_MVN = Qmu + *dim_b * *K; // place to store Q %*% mu
mu_full = dwork_MVN + *dim_b; // (canonical) mean of the proposal distribution
mu_full2 = mu_full + *dim_b; // (canonical) mean of the reversal proposal distribution
Li_full = mu_full2 + *dim_b; // precision/Cholesky decomposition of the proposal distribution
Li_full2 = Li_full + *LT_b; // precision/Cholesky decomposition of the reversal proposal distribution
Imat = Li_full2 + *LT_b; // information matrix given response
bscaled_prop = Imat + *LT_b; // proposed bscaled
b_prop = bscaled_prop + *dim_b; // proposed b
Li_full_backup = b_prop + *dim_b; // backup of the full conditional (inverse) variance
// (stored in the lower triangle of the full matrix, upper triangle filled arbitrarily)
/*** eta_random_prop and mean_Y_d_prop are set-up inside the loop below ***/
/*** Compute Qmu[k] = Q[k] * mu[k] ***/
/*** ============================= ***/
Qmu_resp = Qmu;
Q_i = Q;
mu_resp = mu;
for (k = 0; k < *K; k++){
F77_CALL(dspmv)("L", dim_b, &AK_Basic::_ONE_DOUBLE, Q_i, mu_resp, &AK_Basic::_ONE_INT, &AK_Basic::_ZERO_DOUBLE, Qmu_resp, &AK_Basic::_ONE_INT);
Qmu_resp += *dim_b;
Q_i += *LT_b;
mu_resp += *dim_b;
}
/***** DEBUG CODE *****/
//if (iteration == iter_show){
// Rprintf((char*)("\nsigma <- %g"), *sigma);
// Rprintf((char*)("\nmu <- "));
// AK_Basic::printMatrix4R(mu, *dim_b, *K);
// for (k = 0; k < *K; k++){
// Rprintf((char*)("Q[[%d]] <- "), k+1);
// AK_Basic::printSP4R(Q + k * *LT_b, *dim_b);
// }
// Rprintf((char*)("\nQmu <- "));
// AK_Basic::printMatrix4R(Qmu, *dim_b, *K);
// Rprintf((char*)("\nr <- %d\n"), r[clus_show] + 1);
// Rprintf((char*)("\nbstar <- "));
// AK_Basic::printVec4R(bscaled + clus_show * *dim_b, *dim_b);
// Rprintf((char*)("b <- "));
// AK_Basic::printVec4R(b + clus_show * *dim_b, *dim_b);
//}
/***** END DEBUG CODE *****/
/*** Init for some pointers ***/
/*** ====================== ***/
for (s = 0; s < *R_c; s++){
eta_fixedrespP[s] = eta_fixedresp[s];
eta_randomrespP[s] = eta_randomresp[s];
eta_zsrespP[s] = eta_zsresp[s];
etarespP[s] = etaresp[s];
meanYrespP[s] = meanYresp[s];
dYrespP[s] = dYresp[s];
ZrespP[s] = Zresp[s];
nrespP[s] = nresp[s];
Y_crespP[s] = Y_cresp[s];
}
for (s; s < *R_c + *R_d; s++){
eta_fixedrespP[s] = eta_fixedresp[s];
eta_randomrespP[s] = eta_randomresp[s];
// do not set eta_zsresp[s] for discrete responses (they are not needed)
etarespP[s] = etaresp[s];
meanYrespP[s] = meanYresp[s];
dYrespP[s] = dYresp[s];
ZrespP[s] = Zresp[s];
nrespP[s] = nresp[s];
Y_drespP[s - *R_c] = Y_dresp[s - *R_c];
}
/*** Declaration of functions to compute log-likelihood, score and information matrix ***/
/*** ================================================================================ ***/
void
(*LogLik1)(double*, double*, double*, double*, double*,
const double*, const double*,
const int*, const double*, const double*, const double*, const double*,
const int*, const int*, const int*); // this one also updates linear predictors and means
void
(*LogLik2)(double*, double*, double*,
const double*, const double*, const double*,
const int*, const double*, const double*, const double*, const double*,
const int*, const int*, const int*); // this one computes ll, U, I from supplied eta and E(Y)
/*** Loop to update values of random effects ***/
/*** ======================================= ***/
bscaled_i = bscaled;
b_i = b;
r_i = r;
SZitZiS_i = SZitZiS;
N_iP = N_i;
naccept_i = naccept;
for (i = 0; i < *I; i++){ /*** loop over clusters ***/
Q_i = Q + *r_i * *LT_b;
Qmu_i = Qmu + *r_i * *dim_b;
/*** Init pointers that will shift ***/
/*** ++++++++++++++++++++++++++++++ ***/
qP = q;
randIntcptP = randIntcpt;
q_riP = q_ri;
cumq_riP = cumq_ri;
distP = dist;
mu_full_resp = mu_full;
Li_full_resp = Li_full;
mu_full2_resp = mu_full2;
Li_full2_resp = Li_full2;
Qmu_resp = Qmu_i;
scale_resp = scale;
bscaled_resp = bscaled_i;
SZitZiS_resp = SZitZiS_i;
/*** Reset loglikelihood evaluated at current value of b ***/
/*** +++++++++++++++++++++++++++++++++++++++++++++++++++ ***/
loglik = 0.0;
/*** First part of the precision matrix of the full conditional distribution ***/
/*** and also of the reversal proposal distribution ***/
/*** Li_full = Li_full2 = Q[r[i]] ***/
/*** +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ***/
AK_Basic::copyArray(Li_full, Q_i, *LT_b);
AK_Basic::copyArray(Li_full2, Q_i, *LT_b);
/*** Loop over continuous response types ***/
/*** +++++++++++++++++++++++++++++++++++++ ***/
sigma_resp = sigma;
s = 0;
while (s < *R_c){ /** loop over continuous response variables **/
/*** Log-likelihood contribution evaluated at current values of random effects ***/
/*** (needed only when there are some discrete responses below) ***/
if (*R_d){
LogLik::Gauss_Identity4(&loglik_s, eta_randomrespP[s], eta_fixedrespP[s], Y_crespP[s], sigma_resp, nrespP[s]);
loglik += loglik_s;
}
/*** First part of the canonical mean of full conditional distribution ***/
/*** = sum[observations within cluster i] z[s,i,j]*(y[s,i,j] - eta_fixed[s,i,j] - eta_zs[s,i,j]) ***/
AK_Basic::fillArray(mu_full_resp, 0.0, *q_riP);
if (*(nrespP[s])){
Y_cP = Y_crespP[s];
eta_fixedP = eta_fixedrespP[s];
eta_zsP = eta_zsrespP[s];
zP = ZrespP[s];
for (j = 0; j < *(nrespP[s]); j++){ /** loop over observations within clusters **/
mu_fullP = mu_full_resp;
resid = *Y_cP - *eta_fixedP - *eta_zsP;
if (*randIntcptP){
*mu_fullP += resid;
mu_fullP++;
}
for (k = 0; k < *qP; k++){
*mu_fullP += *zP * resid;
mu_fullP++;
zP++;
}
Y_cP++;
eta_fixedP++;
eta_zsP++;
} /** end of loop j **/
if (!(*R_d)){ /** shift the following pointers only when there is no discrete response **/
/** otherwise, do not shift them as we will need them once more to calculate the proposed value of the log-likelihood **/
Y_crespP[s] = Y_cP;
}
eta_zsrespP[s] = eta_zsP;
} /** end of if (*nrespP[s]) **/
/*** Second part of the canonical mean of full conditional distribution ***/
/*** *= scale_b/(sigma[s] * sigma[s]) ***/
/*** += Q[r[i]]*mu[r[i]] ***/
/*** ***/
/*** Copy also to mu_full2 (will be needed when R_d > 0) ***/
for (k = 0; k < *q_riP; k++){
*mu_full_resp *= *scale_resp / (*sigma_resp * *sigma_resp);
*mu_full_resp += *Qmu_resp;
*mu_full2_resp = *mu_full_resp;
mu_full_resp++;
mu_full2_resp++;
Qmu_resp++;
scale_resp++;
}
/*** Second part of the precision matrix of the full conditional distribution ***/
/*** += (1/(sigma[s]*sigma[s]))* S[s,s]*Z[s,i]'*Z[s,i]*S[s,s] ***/
/*** !!! There are zeros added under Z[s,i]'*Z[s,i] block in Q_full !!! ***/
/*** ***/
/*** Copy also to Li_full2 ***/
itmp = (s > 0 ? *(cumq_riP - 1) : 0);
for (k = itmp; k < *cumq_riP; k++){ /** loop over columns **/
j = k;
while (j < *cumq_riP){ /** loop over rows corresponding to S[s,s]*Z[s,i]'*Z[s,i]*S[s,s] block **/
*Li_full_resp += *SZitZiS_resp / (*sigma_resp * *sigma_resp);
*Li_full2_resp = *Li_full_resp;
SZitZiS_resp++;
Li_full_resp++;
Li_full2_resp++;
j++;
}
while (j < *dim_b){ /** loop over rows with zeros **/
Li_full_resp++;
Li_full2_resp++;
j++;
}
}
/*** Shift pointers (not yet shifted in the code above) ***/
bscaled_resp += *q_riP;
sigma_resp++;
qP++;
randIntcptP++;
q_riP++;
cumq_riP++;
distP++;
s++;
} /** end of loop s over continuous response variables */
/*** Loop over discrete response types ***/
/*** +++++++++++++++++++++++++++++++++++++ ***/
while (s < *R_c + *R_d){
/*** Determine the right log-likelihood function ***/
switch (*distP){
case GLMM::BERNOULLI_LOGIT:
LogLik2 = LogLik::Bernoulli_LogitUI2;
break;
case GLMM::POISSON_LOG:
LogLik2 = LogLik::Poisson_LogUI2;
break;
default:
*err = 1;
error("%s: Unimplemented distributional type (%d).\n", fname, *distP);
}
/*** Compute log-likelihood, score and information matrix for current estimates. ***/
/*** Score will be stored in mu_full_resp. ***/
/*** Information matrix will be stored in Imat. ***/
LogLik2(&loglik_s, mu_full_resp, Imat, eta_randomrespP[s], eta_fixedrespP[s], meanYrespP[s],
Y_drespP[s - *R_c], dYrespP[s], scale_resp, ZrespP[s], SZitZiS_resp, nrespP[s], qP, randIntcptP);
if (!R_finite(loglik_s)){
*err = 1;
/***** DEBUG CODE *****/
//Rprintf((char*)("\nResponse profile %d, cluster %d:\n"), s + 1, i + 1);
//Rprintf((char*)("Y <- "));
//AK_Basic::printVec4R(Y_drespP[s - *R_c], *nrespP[s]);
//Rprintf((char*)("Yhat <- "));
//AK_Basic::printVec4R(mean_Y_drespP[s - *R_c], *nrespP[s]);
//Rprintf((char*)("eta.random <- "));
//AK_Basic::printVec4R(eta_randomrespP[s], *nrespP[s]);
//Rprintf((char*)("eta.fixed <- "));
//AK_Basic::printVec4R(eta_fixedrespP[s], *nrespP[s]);
/***** END DEBUG CODE *****/
error("%s: TRAP, infinite log-likelihood for response profile %d, cluster %d.\n", fname, s + 1, i + 1);
}
loglik += loglik_s;
/*** Canonical mean of the s-th block of the proposal distribution (will be stored in mu_full_resp) ***/
MCMC::Moments_NormalApprox(mu_full_resp, dwork_MVN, bscaled_resp, Imat, Qmu_resp, q_riP);
/*** Add Imat to a proper block of Li_full ***/
/*** (this corresponds to the second part of the precision matrix of the full conditional distribution ***/
/*** in the case of continuous response above) ***/
itmp = (s > 0 ? *(cumq_riP - 1) : 0);
ImatP = Imat;
for (k = itmp; k < *cumq_riP; k++){ /** loop over columns **/
j = k;
while (j < *cumq_riP){ /** loop over rows corresponding to S[s,s]*Z[s,i]'*Z[s,i]*S[s,s] block **/
*Li_full_resp += *ImatP;
ImatP++;
Li_full_resp++;
j++;
}
while (j < *dim_b){ /** loop over rows with zeros **/
Li_full_resp++;
j++;
}
}
/*** Shift pointers (not yet shifted in the code above) ***/
/*** REMARK: Do not shift mu_full2_resp and Li_full2_resp, ***/
/*** later on, their current locations to the start of blocks corresponding ***/
/*** to the first discrete response will be needed. ***/
bscaled_resp += *q_riP;
mu_full_resp += *q_riP;
Qmu_resp += *q_riP;
scale_resp += *q_riP;
SZitZiS_resp += ((*q_riP * (1 + *q_riP)) / 2) * (*(nrespP[s]));
qP++;
randIntcptP++;
q_riP++;
cumq_riP++;
distP++;
s++;
}
/*** Backup of Li_full in the lower triangle of Li_full_backup (which is full matrix) ***/
/*** ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ***/
/*** BACKUP CANCELED ON 24/03/2010 ***/
/*** When dpptrf fails then there are serious numerical problems which leads to failure of anything else ***/
/*** (only slightly later on). ***/
//Li_fullP = Li_full;
//Li_full_backupP = Li_full_backup;
//for (col = 0; col < *dim_b; col++){
// Li_full_backupP += col;
// for (row = col; row < *dim_b; row++){
// *Li_full_backupP = *Li_fullP;
// Li_full_backupP++;
// Li_fullP++;
// }
//}
/***** DEBUG CODE *****/
//if (i == clus_show && iteration == iter_show){
// Rprintf((char*)("\nm <- "));
// AK_Basic::printVec4R(mu_full, *dim_b);
// Rprintf((char*)("\nM <- "));
// AK_Basic::printSP4R(Li_full, *dim_b);
//}
/***** END DEBUG CODE *****/
/*** Cholesky decomposition of precision matrix Q_full of full conditional/proposal distribution of bscaled[i] ***/
/*** +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ***/
F77_CALL(dpptrf)("L", dim_b, Li_full, err); /** this should never fail... **/
if (*err){
/*** Try dpotrf, it happens sometimes that dpptrf fails but dpotrf not ***/
/*** +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ***/
//F77_CALL(dpotrf)("L", dim_b, Li_full_backup, dim_b, err);
if (*err) error("%s: Cholesky decomposition of the precision matrix of full conditional distribution failed (cluster %d).\n", fname, i + 1);
/*** Copy lower triangle of Li_full_backup back to Li_full ***/
/*** +++++++++++++++++++++++++++++++++++++++++++++++++++++ ***/
//Li_fullP = Li_full;
//Li_full_backupP = Li_full_backup;
//for (col = 0; col < *dim_b; col++){
// Li_full_backupP += col;
// for (row = col; row < *dim_b; row++){
// *Li_fullP = *Li_full_backupP;
// Li_full_backupP++;
// Li_fullP++;
// }
//}
}
/*** Compute log(|Q_full|^{1/2}) = sum(log(Li_full[j,j])) ***/
/*** ++++++++++++++++++++++++++++++++++++++++++++++++++++ ***/
Li_full_resp = Li_full;
*log_dets_full = 0.0;
for (j = *dim_b; j > 0; j--){ /** loop over a diagonal of Li **/
*log_dets_full += AK_Basic::log_AK(*Li_full_resp);
Li_full_resp += j;
}
/***** DEBUG CODE *****/
//if (i == clus_show){
// Rprintf("\nCluster %d (loglik=%g):\n", clus_show + 1, loglik);
// Rprintf("cmu <- ");
// AK_Basic::printVec4R(mu_full, *dim_b);
// Rprintf("Li <- ");
// AK_Basic::printLT4R(Li_full, *dim_b);
// Rprintf("iD <- Li %%*%% t(Li)\n");
// Rprintf("muf <- solve(iD, cmu)\n");
// Rprintf("log_det <- %g\n", *log_dets_full);
//}
/***** END DEBUG CODE *****/
/*** +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ***/
/*** Further, if there are no discrete responses, then we can directly sample a new value of random effect ***/
/*** which is automatically accepted. If there are also discrete responses, then we have to propose a new value, ***/
/*** construct reversal proposal and perform Metropolis-Hastings test of acceptance. ***/
/***
/*** +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ***/
if (*R_d){
/*** Sample proposal b[i] (if there are only continuous responses then this is directly a new value of b) ***/
/*** ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ***/
Dist::rMVN3(bscaled_prop, mu_full, &logq, Li_full, log_dets_full, sqrt_tune_scale, log_sqrt_tune_scale, dim_b);
/*** Construct reversal proposal ***/
/*** REMARK: canonical mean and block of the precision matrix corresponding to continuous responses ***/
/*** do not depend on bscaled and hence do not have to be re-calculated ***/
/*** (they are stored in mu_full2 and Li_full2 where further mu_full2_resp and Li_full2_resp ***/
/*** point to the start of blocks corresponding to the first discrete response) ***/
/*** +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ***/
accept = 1; /** proposal still has a chance to be accepted **/
/*** Additional pointers in dwork ***/
eta_random_prop = Li_full_backup + *dim_b * *dim_b;
mean_Y_d_prop = eta_random_prop + *N_iP;
/*** Init pointers ***/
Qmu_resp = Qmu_i;
qP = q;
randIntcptP = randIntcpt;
q_riP = q_ri;
cumq_riP = cumq_ri;
distP = dist;
shift_resp = shift;
scale_resp = scale;
bscaled_resp = bscaled_prop;
b_resp = b_prop;
SZitZiS_resp = SZitZiS_i;
eta_random_propP = eta_random_prop;
mean_Y_d_propP = mean_Y_d_prop;
/*** Reset loglikelihood evaluated at proposed value of b ***/
/*** ++++++++++++++++++++++++++++++++++++++++++++++++++++ ***/
loglik_prop = 0.0;
/*** Loop over continuous response types ***/
/*** +++++++++++++++++++++++++++++++++++++ ***/
sigma_resp = sigma;
s = 0;
while (s < *R_c){ /** loop over continuous response variables **/
/*** Compute b_prop (pointed to by b_resp), shift bscaled_resp ***/
bP = b_resp;
for (k = 0; k < *q_riP; k++){
*bP = *shift_resp + *scale_resp * *bscaled_resp;
bP++;
bscaled_resp++;
shift_resp++;
scale_resp++;
}
/*** Log-likelihood contribution evaluated at proposed values of random effects ***/
/*** Compute also proposed value of the random effect related linear predictor ***/
LogLik::Gauss_Identity3(&loglik_s, eta_random_propP, eta_fixedrespP[s], b_resp, Y_crespP[s], sigma_resp, ZrespP[s], nrespP[s], qP, randIntcptP);
loglik_prop += loglik_s;
/*** Shift pointers (not yet shifted in the code above) ***/
Qmu_resp += *q_riP;
b_resp += *q_riP;
eta_random_propP += *(nrespP[s]);
SZitZiS_resp += (*q_riP * (1 + *q_riP)) / 2;
sigma_resp++;
qP++;
randIntcptP++;
q_riP++;
cumq_riP++;
distP++;
s++;
} /** end of loop over continuous response variables **/
/*** Loop over discrete response types ***/
/*** +++++++++++++++++++++++++++++++++++ ***/
while (s < *R_c + *R_d){ /** loop over discrete response variables **/
/*** Determine the right log-likelihood function ***/
switch (*distP){
case GLMM::BERNOULLI_LOGIT:
LogLik1 = LogLik::Bernoulli_LogitUI1;
break;
case GLMM::POISSON_LOG:
LogLik1 = LogLik::Poisson_LogUI1;
break;
default:
*err = 1;
error("%s: Unimplemented distributional type (%d).\n", fname, *distP);
}
/*** Compute b_prop (pointed to by b_resp), shift bscaled_resp ***/
bP = b_resp;
bscaledP = bscaled_resp;
for (k = 0; k < *q_riP; k++){
*bP = *shift_resp + *scale_resp * *bscaledP;
bP++;
bscaledP++;
shift_resp++;
scale_resp++;
}
scale_resp -= *q_riP; /** scale will be needed again to compute score and information matrix **/
/*** Compute log-likelihood, score and information matrix for proposed value. ***/
/*** Score will be stored in mu_full2_resp. ***/
/*** Information matrix will be stored in Imat. ***/
/*** Compute proposed values of the random effect linear predictor. ***/
/*** Compute proposed value of the response mean. ***/
LogLik1(&loglik_s, mu_full2_resp, Imat, eta_random_propP, mean_Y_d_propP,
eta_fixedrespP[s], b_resp, Y_drespP[s - *R_c], dYrespP[s], scale_resp, ZrespP[s], SZitZiS_resp, nrespP[s], qP, randIntcptP);
if (!R_finite(loglik_s)){ /*** Proposal does not have a chance to be accepted ***/
accept = 0;
//Rprintf((char*)("\n### i = %d: infinite proposal likelihood\n "), i);
/*** Shift SZitZiS_resp to the start of the next cluster (it is used to move SZitZiS_i at the end of loop over i) ***/
/*** and the subsequent break causes that it is not properly shifted ***/
SZitZiS_resp += ((*q_riP * (1 + *q_riP)) / 2) * (*(nrespP[s]));
q_riP++;
s++;
while (s < *R_c + *R_d){
SZitZiS_resp += ((*q_riP * (1 + *q_riP)) / 2) * (*(nrespP[s]));
q_riP;
s++;
}
break;
}
loglik_prop += loglik_s;
/*** Canonical mean of the s-th block of the proposal distribution (will be stored in mu_full2_resp) ***/
MCMC::Moments_NormalApprox(mu_full2_resp, dwork_MVN, bscaled_resp, Imat, Qmu_resp, q_riP);
/*** Add Imat to a proper block of Li_full2 ***/
/*** (this corresponds to the second part of the precision matrix of the full conditional distribution ***/
/*** in the case of continuous response above) ***/
itmp = (s > 0 ? *(cumq_riP - 1) : 0);
ImatP = Imat;
for (k = itmp; k < *cumq_riP; k++){ /** loop over columns **/
j = k;
while (j < *cumq_riP){ /** loop over rows corresponding to S[s,s]*Z[s,i]'*Z[s,i]*S[s,s] block **/
*Li_full2_resp += *ImatP;
ImatP++;
Li_full2_resp++;
j++;
}
while (j < *dim_b){ /** loop over rows with zeros **/
Li_full2_resp++;
j++;
}
}
/*** Shift pointers (not yet shifted in the code above) ***/
Qmu_resp += *q_riP;
scale_resp += *q_riP;
b_resp += *q_riP;
bscaled_resp += *q_riP;
eta_random_propP += *(nrespP[s]);
mean_Y_d_propP += *(nrespP[s]);
SZitZiS_resp += ((*q_riP * (1 + *q_riP)) / 2) * (*(nrespP[s]));
mu_full2_resp += *q_riP;
qP++;
randIntcptP++;
q_riP++;
cumq_riP++;
distP++;
s++;
} /** end of loop over discrete response variables **/
if (accept){ /** if there is still a chance to be accepted **/
/***** DEBUG CODE *****/
//if (i == clus_show && iteration == iter_show){
// Rprintf((char*)("\nM2 <- "));
// AK_Basic::printSP4R(Li_full2, *dim_b);
//}
/***** END DEBUG CODE *****/
/*** Cholesky decomposition of precision matrix of the reversal proposal distribution of bscaled[i] ***/
F77_CALL(dpptrf)("L", dim_b, Li_full2, err); /** this should never fail... **/
if (*err){
error("%s: Cholesky decomposition of the precision matrix of the reversal proposal distribution failed (cluster %d).\n", fname, i + 1);
}
/*** Compute log(|Q_reversal|^{1/2}) = sum(log(Li_full2[j,j])) ***/
Li_full2_resp = Li_full2;
*log_dets_full = 0.0;
for (j = *dim_b; j > 0; j--){ /** loop over a diagonal of Li **/
*log_dets_full += AK_Basic::log_AK(*Li_full2_resp);
Li_full2_resp += j;
}
/*** Mean of the reversal proposal distribution ***/
/*** = (t(Li_full2))^{-1} %*% Li_full2^{-1} %*% mu_full2 ***/
AK_LAPACK::chol_solve_forward(mu_full2, Li_full2, dim_b);
AK_LAPACK::chol_solve_backward(mu_full2, Li_full2, dim_b);
/*** Second part of the proposal ratio: log-q(bscaled[proposed], bscaled) --> stored in logq_prop ***/
Dist::ldMVN3(&logq_prop, dwork_MVN, bscaled_i, mu_full2, Li_full2, log_dets_full, sqrt_tune_scale, log_sqrt_tune_scale, dim_b);
/*** Logarithm of the prior density evaluated at bscaled_i and bscaled_prop ***/
mu_i = mu + *r_i * *dim_b;
Li_i = Li + *r_i * *LT_b;
log_dets_i = log_dets + *r_i * 2;
Dist::ldMVN1(&logprior, dwork_MVN, bscaled_i, mu_i, Li_i, log_dets_i, dim_b);
Dist::ldMVN1(&logprior_prop, dwork_MVN, bscaled_prop, mu_i, Li_i, log_dets_i, dim_b);
/*** Logarithm of the proposal ratio and acceptance test ***/
log_prop_ratio = loglik_prop + logprior_prop + logq_prop - loglik - logprior - logq;
accept = MCMC::accept_Metropolis_Hastings(log_prop_ratio);
/***** DEBUG CODE *****/
//if (i == clus_show){
// Rprintf("\nCluster %d:\n", clus_show + 1);
// Rprintf((char*)("bstar_prop <- "));
// AK_Basic::printVec4R(bscaled_prop, *dim_b);
// Rprintf("loglik <- %g\n", loglik);
// Rprintf("loglik_prop <- %g\n", loglik_prop);
// Rprintf("logq <- %g\n", logq);
// Rprintf("logq_prop <- %g\n", logq_prop);
// Rprintf("logprior <- %g\n", logprior);
// Rprintf("logprior_prop <- %g\n", logprior_prop);
// Rprintf((char*)("prat <- %g\n"), exp(log_prop_ratio));
//}
/***** END DEBUG CODE *****/
} /** end of if there is still a chance to be accepted **/
/*** Make the proposed value the new value if accepted ***/
/*** +++++++++++++++++++++++++++++++++++++++++++++++++ ***/
if (accept){
*naccept_i += 1;
/*** Copy proposed values of random effects and shift b_i, bscaled_i ***/
bP = b_prop;
bscaledP = bscaled_prop;
for (k = 0; k < *dim_b; k++){
*b_i = *bP;
*bscaled_i = *bscaledP;
b_i++;
bscaled_i++;
bP++;
bscaledP++;
}
/*** Copy proposed values of eta_random and meanY ***/
/*** Shift eta_randomrespP[s], mean_YrespP[s], etarespP[s] ***/
/*** Shift eta_fixedrespP[s], ZrespP[s], nrespP[s], Y_crespP[s], Y_drespP[s], dYrespP[s] ***/
eta_random_propP = eta_random_prop;
mean_Y_d_propP = mean_Y_d_prop;
qP = q;
s = 0;
while (s < *R_c){
for (j = 0; j < *(nrespP[s]); j++){
*(eta_randomrespP[s]) = *eta_random_propP;
*(etarespP[s]) = *eta_random_propP + *(eta_fixedrespP[s]);
*(meanYrespP[s]) = *(etarespP[s]);
eta_random_propP++;
eta_fixedrespP[s]++;
eta_randomrespP[s]++;
etarespP[s]++;
meanYrespP[s]++;
}
dYrespP[s] += *(nrespP[s]);
ZrespP[s] += *(nrespP[s]) * *qP;
Y_crespP[s] += *(nrespP[s]);
nrespP[s]++;
qP++;
s++;
}
while (s < *R_c + *R_d){
for (j = 0; j < *(nrespP[s]); j++){
*(eta_randomrespP[s]) = *eta_random_propP;
*(etarespP[s]) = *eta_random_propP + *(eta_fixedrespP[s]);
*(meanYrespP[s]) = *mean_Y_d_propP;
eta_random_propP++;
mean_Y_d_propP++;
eta_fixedrespP[s]++;
eta_randomrespP[s]++;
etarespP[s]++;
meanYrespP[s]++;
}
dYrespP[s] += *(nrespP[s]);
ZrespP[s] += *(nrespP[s]) * *qP;
Y_drespP[s - *R_c] += *(nrespP[s]);
nrespP[s]++;
qP++;
s++;
}
}
else{ /** else accept **/
/*** Shift pointers shifted also in the above code ***/
b_i += *dim_b;
bscaled_i += *dim_b;
qP = q;
s = 0;
while (s < *R_c){
eta_randomrespP[s] += *(nrespP[s]);
eta_fixedrespP[s] += *(nrespP[s]);
etarespP[s] += *(nrespP[s]);
meanYrespP[s] += *(nrespP[s]);
dYrespP[s] += *(nrespP[s]);
ZrespP[s] += *(nrespP[s]) * *qP;
Y_crespP[s] += *(nrespP[s]);
nrespP[s]++;
qP++;
s++;
}
while (s < *R_c + *R_d){
eta_randomrespP[s] += *(nrespP[s]);
eta_fixedrespP[s] += *(nrespP[s]);
etarespP[s] += *(nrespP[s]);
meanYrespP[s] += *(nrespP[s]);
dYrespP[s] += *(nrespP[s]);
ZrespP[s] += *(nrespP[s]) * *qP;
Y_drespP[s - *R_c] += *(nrespP[s]);
nrespP[s]++;
qP++;
s++;
}
}
} /** end of if (*R_d) **/
else{ /** *R_d == 0 **/
/*** Sample new bscaled[i] ***/
/*** +++++++++++++++++++++ ***/
Dist::rMVN2(bscaled_i, mu_full, &logq, Li_full, log_dets_full, dim_b);
*naccept_i += 1;
/*** Update values of linear predictors ***/
/*** and values of b = shift + scale * bscaled ***/
/*** ***/
/*** +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ***/
/*** The code below also shifts several pointers: ***/
/*** ***/
/*** +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ***/
shift_resp = shift;
scale_resp = scale;
qP = q;
randIntcptP = randIntcpt;
q_riP = q_ri;
for (s = 0; s < *R_c; s++){ /** loop over response variables **/
/*** The code below shifts: bscaled_i ***/
bP = b_i;
for (k = 0; k < *q_riP; k++){
*bP = *shift_resp + *scale_resp * *bscaled_i;
bP++;
bscaled_i++;
shift_resp++;
scale_resp++;
}
/*** The code below shifts: b_i, eta_randomrespP[s], eta_fixedrespP, etarespP[s], meanYrespP[s], ZrespP[s] ***/
if (*(nrespP[s])){
for (j = 0; j < *(nrespP[s]); j++){ /** loop over observations within clusters **/
bP = b_i;
*(eta_randomrespP[s]) = 0.0;
if (*randIntcptP){
*(eta_randomrespP[s]) += *bP;
bP++;
}
for (k = 0; k < *qP; k++){
*(eta_randomrespP[s]) += *bP * *(ZrespP[s]);
bP++;
ZrespP[s]++;
}
*(etarespP[s]) = *(eta_randomrespP[s]) + *(eta_fixedrespP[s]);
*(meanYrespP[s]) = *(etarespP[s]);
eta_fixedrespP[s]++;
eta_randomrespP[s]++;
etarespP[s]++;
meanYrespP[s]++;
}
b_i = bP;
}
else{
b_i += *q_riP;
}
qP++;
randIntcptP++;
q_riP++;
nrespP[s]++;
} /** end of loop s **/
} /** end of else (*R_d) **/
SZitZiS_i = SZitZiS_resp;
r_i++;
N_iP++;
naccept_i++;
} /** end of loop i (over clusters) **/
return;
}
void Hung_Chiang(double *time, int *n_time, double *stime, double *event, int *n_stime,
double *stime_new, double *event_new, int *n_stime_new,
double *lpnew, int *n_lpnew, double *ans, double *i_auc)
{
int i, j, k;
double *SX, *SXa, *St, *Sta, *Sc, *Sca;
double *tmp_status, *Sc_stime, *Sc_event;
double tmp_nen = 0.0;
Sc_stime = Calloc(*n_stime, double);
Sc_event = Calloc(*n_stime, double);
SX = Calloc(*n_stime, double);
St = Calloc(*n_stime, double);
Sc = Calloc(*n_stime, double);
tmp_status = Calloc(*n_stime, double);
SXa = Calloc(*n_time, double);
Sta = Calloc(*n_time, double);
Sca = Calloc(*n_stime_new, double);
for(i=0; i<*n_stime; i++){
tmp_status[i] = 1.0;
Sc_stime[i] = stime[i];
Sc_event[i] = 1.0 - event[i];
}
km_Daim(St, stime, event, n_stime);
step_eval2(Sta, time, St, stime, *n_time, *n_stime);
km_Daim(SX, stime, tmp_status, n_stime);
step_eval2(SXa, time, SX, stime, *n_time, *n_stime);
km_Daim(Sc, Sc_stime, Sc_event, n_stime);
step_eval2(Sca, stime_new, Sc, Sc_stime, *n_stime_new, *n_stime);
/* Calculation of AUC */
for(k=0; k<*n_time; k++){
for(i=0; i<*n_lpnew; i++){
for(j=0; j<*n_lpnew; j++){
if(i != j && ((event_new[i] && (lpnew[i] > lpnew[j]) && (stime_new[i] <= time[k] && stime_new[j] > time[k])) && (Sca[i] > FLT_EPSILON))){
ans[k] += 1.0 / (Sca[i]);
}
}
}
tmp_nen = SXa[k]*(1.0-Sta[k])*(*n_lpnew)*(*n_lpnew-1);
if(tmp_nen > FLT_EPSILON)
ans[k] /= tmp_nen;
else
ans[k] = 0.0;
}
Free(SX);Free(SXa);Free(Sc);Free(Sca);Free(St);
Free(Sta);Free(Sc_event);Free(Sc_stime);Free(tmp_status);
/* Calculation of iAUC */
double *f, *S, *S_new;
f = Calloc(*n_time, double);
S_new = Calloc(*n_stime_new, double);
S = Calloc(*n_time, double);
km_Daim(S_new, stime_new, event_new, n_stime_new);
step_eval2(S, time, S_new, stime_new, *n_time, *n_stime_new);
f[0] = 1.0 - S[0];
for(i=1; i<*n_time; i++){
f[i] = S[i-1] - S[i];
}
double wT = 0.0;
for(i=0; i < *n_time; i++){
if(f[i] > FLT_EPSILON){
wT += f[i];
}
}
for(i=0; i < *n_time; i++){
if(wT != 0.0){
/* cumulative case*/
if(f[i] > FLT_EPSILON && R_finite(ans[i]) ){
*i_auc += ans[i] * (f[i]) / wT;
}
}
}
Free(f);Free(S);Free(S_new);
}
// ****** update_Data_GS_regres ***********************
//
// Version with possible regression
// ================================
//
// YsM[nP x gg->dim()] ........... on INPUT: current vector of (imputed) log(event times)
// on OUTPUT: updated vector of (augmented) log(event times)
// regresResM[nP x gg->dim()] .... on INPUT: current vector of regression residuals (y - x'beta - z'b))
// on OUTPUT: updated vector of regression residuals
//
// rM[nP] ........................ component labels taking values 0, 1, ..., gg->total_length()-1
//
void
update_Data_GS_regres(double* YsM,
double* regresResM,
const double* y_left,
const double* y_right,
const int* status,
const int* rM,
const Gspline* gg,
const int* nP)
{
int obs, j;
double mu_jk = 0;
double PhiL = 0;
double PhiU = 0;
double u = 0;
double PhiInv = 0;
double stres = 0;
double invsigma[_max_dim];
double invscale[_max_dim];
for (j = 0; j < gg->dim(); j++){
invsigma[j] = 1/gg->sigma(j);
invscale[j] = 1/gg->scale(j);
}
//Rprintf("\nG-spline dim: %d\n", gg->dim());
//Rprintf("mu[0, 0] = %g\n", gg->mu_component(0, 0));
//Rprintf("sigma[0] = %g\n", gg->sigma(0));
//Rprintf("intcpt[0] = %g\n", gg->intcpt(0));
//Rprintf("scale[0] = %g\n", gg->scale(0));
double* y_obs = YsM;
double* regRes = regresResM;
const double* y1 = y_left;
const double* y2 = y_right;
const int* stat = status;
const int* rp = rM;
for (obs = 0; obs < *nP; obs++){
for (j = 0; j < gg->dim(); j++){
switch (*stat){
case 1: /* exactly observed */
break;
case 0: /* right censored */
mu_jk = gg->mu_component(j, *rp);
*regRes -= *y_obs;
stres = (*y1 + (*regRes) - gg->intcpt(j) - gg->scale(j)*mu_jk) * invsigma[j]*invscale[j];
PhiL = pnorm(stres, 0, 1, 1, 0);
if (PhiL >= 1 - NORM_ZERO){ // censored time irrealistic large (out of the prob. scale)
*y_obs = *y1;
}
else{
if (PhiL <= NORM_ZERO){ // censoring time equal to "zero", generate an exact time from N(mean, variance),
// i.e. from the full not-truncated distribution
u = runif(0, 1);
PhiInv = qnorm(u, 0, 1, 1, 0);
*y_obs = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
else{
u = runif(0, 1) * (1 - PhiL) + PhiL;
PhiInv = qnorm(u, 0, 1, 1, 0);
if (PhiInv == R_PosInf){ // u was equal to 1, additional check added 16/12/2004
*y_obs = *y1;
}
else{
*y_obs = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
}
}
*regRes += (*y_obs);
break;
case 2: /* left censored */
mu_jk = gg->mu_component(j, *rp);
*regRes -= *y_obs;
stres = (*y1 + (*regRes) - gg->intcpt(j) - gg->scale(j)*mu_jk) * invsigma[j]*invscale[j];
PhiU = pnorm(stres, 0, 1, 1, 0);
if (PhiU <= NORM_ZERO){ // left censoring time irrealistic low (equal to "zero")
*y_obs = *y1;
}
else{
if (PhiU >= 1 - NORM_ZERO){ // left censoring time equal to "infty", generate an exact time from N(mean, variance),
// i.e. from the full not-truncated distribution
u = runif(0, 1);
PhiInv = qnorm(u, 0, 1, 1, 0);
*y_obs = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
else{
u = runif(0, 1) * PhiU;
PhiInv = qnorm(u, 0, 1, 1, 0);
if (PhiInv == R_NegInf){ // u was equal to 0, additional check added 16/12/2004
*y_obs = *y1;
}
else{
*y_obs = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
}
}
*regRes += *y_obs;
break;
case 3: /* interval censored */
mu_jk = gg->mu_component(j, *rp);
*regRes -= *y_obs;
stres = (*y1 + (*regRes) - gg->intcpt(j) - gg->scale(j)*mu_jk) * invsigma[j]*invscale[j];
PhiL = pnorm(stres, 0, 1, 1, 0);
stres = (*y2 + (*regRes) - gg->intcpt(j) - gg->scale(j)*mu_jk) * invsigma[j]*invscale[j];
PhiU = pnorm(stres, 0, 1, 1, 0);
PhiInv = PhiU - PhiL;
if (PhiInv <= NORM_ZERO){ // too narrow interval, or the interval out of the probability scale
// (both limits in "zero" probability region)
// generate something inbetween
u = runif(0, 1);
*y_obs = *y1 + u*((*y2) - (*y1));
}
else{
if (PhiInv >= 1 - NORM_ZERO){ // too large interval, practically (-infty, +infty), generate an exact time from N(mean, variance)
u = runif(0, 1);
PhiInv = qnorm(u, 0, 1, 1, 0);
*y_obs = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
else{
u = runif(0, 1) * PhiInv + PhiL;
PhiInv = qnorm(u, 0, 1, 1, 0);
if (!R_finite(PhiInv)){ // u was either zero or one, additional check added 16/12/2004
u = runif(0, 1);
*y_obs = *y1 + u*((*y2) - (*y1));
}
else{
*y_obs = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
}
}
*regRes += *y_obs;
break;
} /** end of switch (status) **/
/*** This section just performs additional checks to prevent simulations with NaN's ***/
if (!R_finite(*y_obs) || !R_finite(*regRes)){
int condit;
REprintf("\nY[%d,%d]=%e, regRes[%d,%d]=%e, r[%d,%d]=%d, status[%d,%d]=%d, stres=%e",
obs, j, *y_obs, obs, j, *regRes, obs, j, *rp, obs, j, *stat, stres);
REprintf("; mean=%e", mu_jk);
REprintf("; invvar=%e", gg->invsigma2(j));
REprintf("\nu=%3.20e, PhiL=%3.20e, PhiU=%3.20e, PhiInv=%3.20e", u, PhiL, PhiU, PhiInv);
REprintf("NORM_ZERO=%3.20e, 1-NORM_ZERO=%3.20e", NORM_ZERO, 1-NORM_ZERO);
switch (*stat){
case 0:
condit = 1*(PhiL >= 1 - NORM_ZERO);
REprintf("\nPhiL >= 1 - NORM_ZERO: %d", condit);
condit = 1*(PhiL <= NORM_ZERO);
REprintf("\nPhiL <= NORM_ZERO: %d", condit);
break;
case 2:
condit = 1*(PhiU >= 1 - NORM_ZERO);
REprintf("\nPhiU >= 1 - NORM_ZERO: %d", condit);
condit = 1*(PhiU <= NORM_ZERO);
REprintf("\nPhiU <= NORM_ZERO: %d", condit);
break;
case 3:
condit = 1*(PhiU-PhiL >= 1 - NORM_ZERO);
REprintf("\nPhiU-PhiL >= 1 - NORM_ZERO: %d", condit);
condit = 1*(PhiU-PhiL <= NORM_ZERO);
REprintf("\nPhiU-PhiL <= NORM_ZERO: %d", condit);
break;
}
REprintf("\n");
throw returnR("Trap in update_Data_GS_regres: NaN generated.", 1);
}
y_obs++;
regRes++;
y1++;
y2++;
stat++;
}
rp++;
}
return;
} /*** end of function update_Data_GS_regres ***/
/***** ***************************************************************************************** *****/
void
loglik_Zwork1_stres(double* loglik,
double* Zwork1,
double* stres,
double* sqrt_w_phi,
int* err,
double** eta_randomresp, // this is in fact const
double** meanYresp, // this is in fact const
double** eta_fixedresp, // this is in fact const
double** dYresp, // this is in fact const
double** Y_cresp, // this is in fact const
int** Y_dresp, // this is in fact const
int** nresp, // this is in fact const
const double* ZS,
const double* sigma,
const int* q_ri,
const int* dist,
const int* R_c,
const int* R_d)
{
/*** - Zwork1 matrix will be stored and filled in COLUMN major order ***/
/*** - Zwork1 has N_iP rows and dim_b columns ***/
/*** - Zwork1 is block diagonal (each block corresponds to one response) ***/
const char *fname = "MCMC::loglik_Zwork1_stres (PROTOTYPE 1)";
static int s, s2, l, j;
static const int *dist_s, *q_ri_s;
static double *Zwork1_s, *stres_s, *sqrt_w_phi_s, *sqrt_w_phiP;
static const double *sigma_s;
static const double *ZSP;
static double loglik_s;
ZSP = ZS;
q_ri_s = q_ri;
dist_s = dist;
*loglik = 0.0;
Zwork1_s = Zwork1;
stres_s = stres;
sqrt_w_phi_s = sqrt_w_phi;
sigma_s = sigma;
for (s = 0; s < *R_c + *R_d; s++){ /*** loop over response profiles ***/
/*** Calculate the current value of the (conditional) log-likelihood value ***/
/*** Fill-in sqrt_w_phi, stres ***/
switch (*dist_s){
case GLMM::GAUSS_IDENTITY:
LogLik::Gauss_Identity_sqrt_w_phi_stres2(&loglik_s, sqrt_w_phi_s, stres_s,
eta_randomresp[s], eta_fixedresp[s], meanYresp[s],
sigma_s, Y_cresp[s], NULL, nresp[s]);
sigma_s++;
break;
case GLMM::BERNOULLI_LOGIT:
LogLik::Bernoulli_Logit_sqrt_phi_stres2(&loglik_s, sqrt_w_phi_s, stres_s,
eta_randomresp[s], eta_fixedresp[s], meanYresp[s],
NULL, Y_dresp[s - *R_c], dYresp[s], nresp[s]);
break;
case GLMM::POISSON_LOG:
LogLik::Poisson_Log_sqrt_w_phi_stres2(&loglik_s, sqrt_w_phi_s, stres_s,
eta_randomresp[s], eta_fixedresp[s], meanYresp[s],
NULL, Y_dresp[s - *R_c], dYresp[s], nresp[s]);
break;
default:
*err = 1;
error("%s: Unimplemented distributional type (%d).\n", fname, *dist_s);
}
if (!R_finite(loglik_s)){
*err = 1;
return;
//error("%s: TRAP, infinite log-likelihood for response profile %d.\n", fname, s + 1);
}
*loglik += loglik_s;
/*** Fill-in Zwork1 ***/
for (l = 0; l < *q_ri_s; l++){ /*** loop over columns of Zwork1 ***/
s2 = 0;
/*** Block of zeros above Zwork1[s, s] block ***/
while (s2 < s){
for (j = 0; j < *nresp[s2]; j++){
*Zwork1_s = 0.0;
Zwork1_s++;
}
s2++;
}
/*** Non-zero block Zwork1[s, s] ***/
sqrt_w_phiP = sqrt_w_phi_s;
for (j = 0; j < *nresp[s2]; j++){
*Zwork1_s = *sqrt_w_phiP * *ZSP;
Zwork1_s++;
sqrt_w_phiP++;
ZSP++; /*** shift ZSP ***/
}
s2++;
/*** Block of zeros below Zwork1[s, s] ***/
while (s2 < *R_c + *R_d){
for (j = 0; j < *nresp[s2]; j++){
*Zwork1_s = 0.0;
Zwork1_s++;
}
s2++;
}
} /*** end of loop over columns of Zwork1 ***/
stres_s += *nresp[s];
sqrt_w_phi_s += *nresp[s];
q_ri_s++;
dist_s++;
} /*** end of loop over response profiles ***/
return;
}
// ****** update_Data_GS_doubly ***********************
// *** Update of the event-time in the case of doubly censored data
//
// Yevent[nP x gg->dim()] ........ on INPUT: current vector of (imputed) log(event times)
// on OUTPUT: updated vector of (augmented) log(event times)
// i.e. augmented log(T2 - T1), where T1 = onset time, T2 = event time (on a study scale)
// regresResM[nP x gg->dim()] .... on INPUT: current vector of regression residuals (y - x'beta - z'b))
// on OUTPUT: updated vector of regression residuals
// Yonset[nP x gg->dim()] .... log-onset times
// i.e. log(T1)
// t_left[nP x gg->dim()] ....
// t_right[nP x gg->dim()].... observed event times (on a study scale)
// status[nP x gg->dim()] .... censoring status for event
// rM[nP] .................... component labels taking values 0, 1, ..., gg->total_length()-1
// gg ........................ G-spline defining the distribution of the log-time-to-event (log(T2 - T1))
// nP ........................ number of observational vectors
// n_censored ................ number of censored event times
//
void
update_Data_GS_doubly(double* Yevent,
double* regresResM,
const double* Yonset,
const double* t_left,
const double* t_right,
const int* status,
const int* rM,
const Gspline* gg,
const int* nP)
{
int obs, j;
double t_onset, yL, yU, help;
double mu_jk = 0;
double PhiL = 0;
double PhiU = 0;
double u = 0;
double PhiInv = 0;
double stres = 0;
double invsigma[_max_dim];
double invscale[_max_dim];
for (j = 0; j < gg->dim(); j++){
invsigma[j] = 1/gg->sigma(j);
invscale[j] = 1/gg->scale(j);
}
double* y_event = Yevent;
double* regRes = regresResM;
const double* y_onset = Yonset;
const double* t1 = t_left;
const double* t2 = t_right;
const int* stat = status;
const int* rp = rM;
for (obs = 0; obs < *nP; obs++){
for (j = 0; j < gg->dim(); j++){
t_onset = (*y_onset > -_emax ? exp(*y_onset) : 0.0);
if (!R_finite(t_onset)) throw returnR("Trap: t_onset equal to NaN in 'update_Data_GS_doubly'", 1);
*regRes -= *y_event;
switch (*stat){
case 1: /* exactly observed, but the onset time might not be observed exactly */
help = (*t1) - t_onset;
if (help <= _ZERO_TIME_) *y_event = _LOG_ZERO_TIME_;
else *y_event = log(help);
break;
case 0: /* right censored */
mu_jk = gg->mu_component(j, *rp);
help = (*t1) - t_onset;
if (help <= _ZERO_TIME_){ // time-to-event right censored at 0, generate an exact time from N(mean, variance)
u = runif(0, 1);
PhiInv = qnorm(u, 0, 1, 1, 0);
*y_event = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
else{
yL = log(help);
stres = (yL + (*regRes) - gg->intcpt(j) - gg->scale(j)*mu_jk) * invsigma[j]*invscale[j];
PhiL = pnorm(stres, 0, 1, 1, 0);
if (PhiL >= 1 - NORM_ZERO){ // censored time irrealistic large (out of the prob. scale)
*y_event = yL;
}
else{
if (PhiL <= NORM_ZERO){ // censoring time equal to "zero", generate an exact time from N(mean, variance),
// i.e. from the full not-truncated distribution
u = runif(0, 1);
PhiInv = qnorm(u, 0, 1, 1, 0);
*y_event = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
else{
u = runif(0, 1) * (1 - PhiL) + PhiL;
PhiInv = qnorm(u, 0, 1, 1, 0);
if (PhiInv == R_PosInf){ // u was equal to 1, additional check added 16/12/2004
*y_event = yL;
}
else{
*y_event = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
}
}
}
break;
case 2: /* left censored event => onset had to be left censored as well at the same time */
mu_jk = gg->mu_component(j, *rp);
help = (*t1) - t_onset;
if (help <= _ZERO_TIME_) *y_event = _LOG_ZERO_TIME_; // time-to-event left censored at 0 => time-to-event = 0
else{
yL = log(help);
stres = (yL + (*regRes) - gg->intcpt(j) - gg->scale(j)*mu_jk) * invsigma[j]*invscale[j];
PhiU = pnorm(stres, 0, 1, 1, 0);
if (PhiU <= NORM_ZERO){ // left censoring time irrealistic low (equal to "zero")
*y_event = _LOG_ZERO_TIME_;
}
else{
if (PhiU >= 1 - NORM_ZERO){ // left censoring time equal to "infty", generate an exact time from N(mean, variance),
// i.e. from the full not-truncated distribution
u = runif(0, 1);
PhiInv = qnorm(u, 0, 1, 1, 0);
*y_event = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
else{
u = runif(0, 1) * PhiU;
PhiInv = qnorm(u, 0, 1, 1, 0);
if (PhiInv == R_NegInf){ // u was equal to 0, additional check added 16/12/2004
*y_event = yL;
}
else{
*y_event = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
}
}
}
break;
case 3: /* interval censored */
mu_jk = gg->mu_component(j, *rp);
help = (*t1) - t_onset;
if (help <= _ZERO_TIME_){ // time-to-event will be left censored
help = (*t2) - t_onset;
if (help <= _ZERO_TIME_){ // too narrow interval located close to zero
*y_event = _LOG_ZERO_TIME_;
}
else{ // code for left censored observations
yL = log(help);
stres = (yL + (*regRes) - gg->intcpt(j) - gg->scale(j)*mu_jk) * invsigma[j]*invscale[j];
PhiU = pnorm(stres, 0, 1, 1, 0);
if (PhiU <= NORM_ZERO){ // left censoring time irrealistic low (equal to "zero")
*y_event = _LOG_ZERO_TIME_;
}
else{
if (PhiU >= 1 - NORM_ZERO){ // left censoring time equal to "infty", generate an exact time from N(mean, variance),
// i.e. from the full not-truncated distribution
u = runif(0, 1);
PhiInv = qnorm(u, 0, 1, 1, 0);
*y_event = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
else{
u = runif(0, 1) * PhiU;
PhiInv = qnorm(u, 0, 1, 1, 0);
if (PhiInv == R_NegInf){ // u was equal to 0, additional check added 16/12/2004
*y_event = yL;
}
else{
*y_event = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
}
}
}
}
else{
yL = log(help);
help = (*t2) - t_onset;
if (help <= _ZERO_TIME_){ // too narrow interval located close to zero
*y_event = _LOG_ZERO_TIME_;
}
else{
yU = log(help);
stres = (yL + (*regRes) - gg->intcpt(j) - gg->scale(j)*mu_jk) * invsigma[j]*invscale[j];
PhiL = pnorm(stres, 0, 1, 1, 0);
stres = (yU + (*regRes) - gg->intcpt(j) - gg->scale(j)*mu_jk) * invsigma[j]*invscale[j];
PhiU = pnorm(stres, 0, 1, 1, 0);
PhiInv = PhiU - PhiL;
if (PhiInv <= NORM_ZERO){ // too narrow interval, or the interval out of the probability scale
// (both limits in "zero" probability region)
// generate something inbetween
u = runif(0, 1);
*y_event = yL + u*(yU - yL);
}
else{
if (PhiInv >= 1 - NORM_ZERO){ // too large interval, practically (-infty, +infty), generate an exact time from N(mean, variance)
u = runif(0, 1);
PhiInv = qnorm(u, 0, 1, 1, 0);
*y_event = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
else{
u = runif(0, 1) * PhiInv + PhiL;
PhiInv = qnorm(u, 0, 1, 1, 0);
if (!R_finite(PhiInv)){ // u was either zero or one, additional check added 16/12/2004
u = runif(0, 1);
*y_event = yL + u*(yU - yL);
}
else{
*y_event = -(*regRes) + gg->intcpt(j) + gg->scale(j)*mu_jk + gg->sigma(j)*gg->scale(j)*PhiInv;
}
}
}
}
}
break;
} /** end of switch (status) **/
*regRes += (*y_event);
/*** This section just performs additional checks to prevent simulations with NaN's ***/
if (!R_finite(*y_event) || !R_finite(*regRes)){
int condit;
REprintf("\nY[%d,%d]=%e, regRes[%d,%d]=%e, r[%d,%d]=%d, status[%d,%d]=%d, stres=%e",
obs, j, *y_event, obs, j, *regRes, obs, j, *rp, obs, j, *stat, stres);
REprintf("; mean=%e", mu_jk);
REprintf("; invvar=%e", gg->invsigma2(j));
REprintf("\nu=%3.20e, PhiL=%3.20e, PhiU=%3.20e, PhiInv=%3.20e", u, PhiL, PhiU, PhiInv);
REprintf("NORM_ZERO=%3.20e, 1-NORM_ZERO=%3.20e", NORM_ZERO, 1-NORM_ZERO);
switch (*stat){
case 0:
condit = 1*(PhiL >= 1 - NORM_ZERO);
REprintf("\nPhiL >= 1 - NORM_ZERO: %d", condit);
condit = 1*(PhiL <= NORM_ZERO);
REprintf("\nPhiL <= NORM_ZERO: %d", condit);
break;
case 2:
condit = 1*(PhiU >= 1 - NORM_ZERO);
REprintf("\nPhiU >= 1 - NORM_ZERO: %d", condit);
condit = 1*(PhiU <= NORM_ZERO);
REprintf("\nPhiU <= NORM_ZERO: %d", condit);
break;
case 3:
condit = 1*(PhiU-PhiL >= 1 - NORM_ZERO);
REprintf("\nPhiU-PhiL >= 1 - NORM_ZERO: %d", condit);
condit = 1*(PhiU-PhiL <= NORM_ZERO);
REprintf("\nPhiU-PhiL <= NORM_ZERO: %d", condit);
break;
}
REprintf("\n");
throw returnR("Trap in update_Data_GS_doubly: NaN generated.", 1);
}
y_event++;
regRes++;
y_onset++;
t1++;
t2++;
stat++;
}
rp++;
}
return;
} /*** end of function update_Data_GS_doubly ***/
//
// Difference to PROTOTYPE 2: bscaled is not supplied, b must be supplied and it is not calculated
//
void
loglik(double* loglik,
int* err,
double** eta_fixedresp, // this is in fact const
double** dYresp, // this is in fact const
double** Y_cresp, // this is in fact const
int** Y_dresp, // this is in fact const
int** nresp, // this is in fact const
double** Zresp, // this is in fact const
const double* b,
const double* sigma,
const int* q,
const int* randIntcpt,
const int* q_ri,
const int* dist,
const int* R_c,
const int* R_d)
{
const char *fname = "MCMC::loglik (PROTOTYPE 3)";
static int s, s2, l;
static const int *dist_s, *q_ri_s, *q_s, *randIntcpt_s;
static const double *b_s;
static const double *sigma_s;
static double loglik_s;
q_s = q;
randIntcpt_s = randIntcpt;
q_ri_s = q_ri;
dist_s = dist;
*loglik = 0.0;
b_s = b;
sigma_s = sigma;
for (s = 0; s < *R_c + *R_d; s++){ /*** loop over response profiles ***/
/*** Calculate the current value of the (conditional) log-likelihood value ***/
switch (*dist_s){
case GLMM::GAUSS_IDENTITY:
LogLik::Gauss_Identity1(&loglik_s,
eta_fixedresp[s], b_s, sigma_s, Y_cresp[s], NULL, Zresp[s], nresp[s], q_s, randIntcpt_s);
sigma_s++;
break;
case GLMM::BERNOULLI_LOGIT:
LogLik::Bernoulli_Logit1(&loglik_s,
eta_fixedresp[s], b_s, NULL, Y_dresp[s - *R_c], dYresp[s], Zresp[s], nresp[s], q_s, randIntcpt_s);
break;
case GLMM::POISSON_LOG:
LogLik::Poisson_Log1(&loglik_s,
eta_fixedresp[s], b_s, NULL, Y_dresp[s - *R_c], dYresp[s], Zresp[s], nresp[s], q_s, randIntcpt_s);
break;
default:
*err = 1;
error("%s: Unimplemented distributional type (%d).\n", fname, *dist_s);
}
if (!R_finite(loglik_s)){
*err = 1;
return;
//error("%s: TRAP, infinite log-likelihood for response profile %d.\n", fname, s + 1);
}
*loglik += loglik_s;
b_s += *q_ri_s;
q_s++;
randIntcpt_s++;
q_ri_s++;
dist_s++;
} /*** end of loop over response profiles ***/
return;
}
double analyseF2(int Nind, int *nummark, cvector *cofactor, MQMMarkerMatrix marker,
vector y, int Backwards, double **QTL,vector
*mapdistance, int **Chromo, int Nrun, int RMLorML, double
windowsize, double stepsize, double stepmin, double stepmax,
double alfa, int em, int out_Naug, int **INDlist, char
reestimate, MQMCrossType crosstype, bool dominance, int verbose) {
if (verbose) Rprintf("INFO: Starting C-part of the MQM analysis\n");
int Naug, Nmark = (*nummark), run = 0;
bool useREML = true, fitQTL = false;
bool warned = false;
ivector chr = newivector(Nmark); // The chr vector contains the chromosome number for every marker
for(int i = 0; i < Nmark; i++){ // Rprintf("INFO: Receiving the chromosome matrix from R");
chr[i] = Chromo[0][i];
}
if(RMLorML == 1) useREML=false; // use ML instead
// Create an array of marker positions - and calculate R[f] based on these locations
cvector position = relative_marker_position(Nmark,chr);
vector r = recombination_frequencies(Nmark, position, (*mapdistance));
//Rprintf("INFO: Initialize Frun and informationcontent to 0.0");
const int Nsteps = (int)(chr[Nmark-1]*((stepmax-stepmin)/stepsize+1));
matrix Frun = newmatrix(Nsteps,Nrun+1);
vector informationcontent = newvector(Nsteps);
for (int i = 0; i < (Nrun+1); i++) {
for (int ii = 0; ii < Nsteps; ii++) {
if(i==0) informationcontent[ii] = 0.0;
Frun[ii][i]= 0.0;
}
}
bool dropj = false;
int jj=0;
// Rprintf("any triple of non-segregating markers is considered to be the result of:\n");
// Rprintf("identity-by-descent (IBD) instead of identity-by-state (IBS)\n");
// Rprintf("no (segregating!) cofactors are fitted in such non-segregating IBD regions\n");
for (int j=0; j < Nmark; j++) { // WRONG: (Nmark-1) Should fix the out of bound in mapdistance, it does fix, but created problems for the last marker
dropj = false;
if(j+1 < Nmark){ // Check if we can look ahead
if(((*mapdistance)[j+1]-(*mapdistance)[j])==0.0){ dropj=true; }
}
if (!dropj) {
marker[jj] = marker[j];
(*cofactor)[jj] = (*cofactor)[j];
(*mapdistance)[jj] = (*mapdistance)[j];
chr[jj] = chr[j];
r[jj] = r[j];
position[jj] = position[j];
jj++;
} else{
if (verbose) Rprintf("INFO: Marker %d at chr %d is dropped\n",j,chr[j]);
if ((*cofactor)[j]==MCOF) {
if (verbose) Rprintf("INFO: Cofactor at chr %d is dropped\n",chr[j]);
}
}
}
//if(verbose) Rprintf("INFO: Number of markers: %d -> %d\n",Nmark,jj);
Nmark = jj;
(*nummark) = jj;
// Update the array of marker positions - and calculate R[f] based on these new locations
position = relative_marker_position(Nmark,chr);
r = recombination_frequencies(Nmark, position, (*mapdistance));
debug_trace("After dropping of uninformative cofactors\n");
ivector newind; // calculate Traits mean and variance
vector newy;
MQMMarkerMatrix newmarker;
double ymean = 0.0, yvari = 0.0;
//Rprintf("INFO: Number of individuals: %d Number Aug: %d",Nind,out_Naug);
int cur = -1;
for (int i=0; i < Nind; i++){
if(INDlist[0][i] != cur){
ymean += y[i];
cur = INDlist[0][i];
}
}
ymean/= out_Naug;
for (int i=0; i < Nind; i++){
if(INDlist[0][i] != cur){
yvari += pow(y[i]-ymean, 2);
cur = INDlist[0][i];
}
}
yvari /= (out_Naug-1);
Naug = Nind; // Fix for not doing dataaugmentation, we just copy the current as the augmented and set Naug to Nind
Nind = out_Naug;
newind = newivector(Naug);
newy = newvector(Naug);
newmarker = newMQMMarkerMatrix(Nmark,Naug);
for (int i=0; i<Naug; i++) {
newy[i]= y[i];
newind[i]= INDlist[0][i];
for (int j=0; j<Nmark; j++) {
newmarker[j][i]= marker[j][i];
}
}
// End fix
vector newweight = newvector(Naug);
double max = rmixture(newmarker, newweight, r, position, newind,Nind, Naug, Nmark, mapdistance,reestimate,crosstype,verbose); //Re-estimation of mapdistances if reestimate=TRUE
if(max > stepmax){ fatal("ERROR: Re-estimation of the map put markers at: %f Cm, run the algorithm with a step.max larger than %f Cm", max, max); }
//Check if everything still is correct positions and R[f]
position = relative_marker_position(Nmark,chr);
r = recombination_frequencies(Nmark, position, (*mapdistance));
/* eliminate individuals with missing trait values */
//We can skip this part iirc because R throws out missing phenotypes beforehand
int oldNind = Nind;
for (int i=0; i<oldNind; i++) {
Nind -= ((y[i]==TRAITUNKNOWN) ? 1 : 0);
}
int oldNaug = Naug;
for (int i=0; i<oldNaug; i++) {
Naug -= ((newy[i]==TRAITUNKNOWN) ? 1 : 0);
}
marker = newMQMMarkerMatrix(Nmark+1,Naug);
y = newvector(Naug);
ivector ind = newivector(Naug);
vector weight = newvector(Naug);
int newi = 0;
for (int i=0; i < oldNaug; i++)
if (newy[i]!=TRAITUNKNOWN) {
y[newi]= newy[i];
ind[newi]= newind[i];
weight[newi]= newweight[i];
for (int j=0; j<Nmark; j++) marker[j][newi]= newmarker[j][i];
newi++;
}
int diff;
for (int i=0; i < (Naug-1); i++) {
diff = ind[i+1]-ind[i];
if (diff>1) {
for (int ii=i+1; ii<Naug; ii++){ ind[ii]=ind[ii]-diff+1; }
}
}
//END throwing out missing phenotypes
double variance=-1.0;
cvector selcofactor = newcvector(Nmark); /* selected cofactors */
int dimx = designmatrixdimensions((*cofactor),Nmark,dominance);
double F1 = inverseF(1,Nind-dimx,alfa,verbose);
double F2 = inverseF(2,Nind-dimx,alfa,verbose);
if (verbose) {
Rprintf("INFO: dimX: %d, nInd: %d\n",dimx,Nind);
Rprintf("INFO: F(Threshold, Degrees of freedom 1, Degrees of freedom 2) = Alfa\n");
Rprintf("INFO: F(%.3f, 1, %d) = %f\n",ftruncate3(F1),(Nind-dimx),alfa);
Rprintf("INFO: F(%.3f, 2, %d) = %f\n",ftruncate3(F2),(Nind-dimx),alfa);
}
F2 = 2.0* F2; // 9-6-1998 using threshold x*F(x,df,alfa)
weight[0]= -1.0;
double logL = QTLmixture(marker,(*cofactor),r,position,y,ind,Nind,Naug,Nmark,&variance,em,&weight,useREML,fitQTL,dominance,crosstype, &warned, verbose);
if(verbose){
if (!R_finite(logL)) {
Rprintf("WARNING: Log-likelihood of full model = INFINITE\n");
}else{
if (R_IsNaN(logL)) {
Rprintf("WARNING: Log-likelihood of full model = NOT A NUMBER (NAN)\n");
}else{
Rprintf("INFO: Log-likelihood of full model = %.3f\n",ftruncate3(logL));
}
}
Rprintf("INFO: Residual variance = %.3f\n",ftruncate3(variance));
Rprintf("INFO: Trait mean= %.3f; Trait variation = %.3f\n",ftruncate3(ymean),ftruncate3(yvari));
}
if (R_finite(logL) && !R_IsNaN(logL)) {
if(Backwards==1){ // use only selected cofactors
logL = backward(Nind, Nmark, (*cofactor), marker, y, weight, ind, Naug, logL,variance, F1, F2, &selcofactor, r,
position, &informationcontent, mapdistance,&Frun,run,useREML,fitQTL,dominance, em, windowsize,
stepsize, stepmin, stepmax,crosstype,verbose);
}else{ // use all cofactors
logL = mapQTL(Nind, Nmark, (*cofactor), (*cofactor), marker, position,(*mapdistance), y, r, ind, Naug, variance,
'n', &informationcontent,&Frun,run,useREML,fitQTL,dominance, em, windowsize, stepsize, stepmin,
stepmax,crosstype,verbose); // printout=='n'
}
}
// Write output and/or send it back to R
// Cofactors that made it to the final model
for (int j=0; j<Nmark; j++) {
if (selcofactor[j]==MCOF) {
(*cofactor)[j]=MCOF;
}else{
(*cofactor)[j]=MNOCOF;
}
}
if (verbose) Rprintf("INFO: Number of output datapoints: %d\n", Nsteps); // QTL likelihood for each location
for (int ii=0; ii<Nsteps; ii++) {
//Convert LR to LOD before sending back
QTL[0][ii] = Frun[ii][0] / 4.60517;
QTL[0][Nsteps+ii] = informationcontent[ii];
}
return logL;
}
