MatrixLT<dataType>::MatrixLT(const int& nrow)
{
int i;
if (nrow < 0) throw returnR("MatrixLT.cpp: MatrixLT::MatrixLT(nrow) error", 1);
_nrow = nrow;
_length = (_nrow * (_nrow+1))/2;
if (_length){
_diagI = (int*) calloc(_nrow, sizeof(int));
if (!_diagI) throw returnR("Out of memory in MatrixLT.cpp: MatrixLT::MatrixLT(nrow)", 99);
for (i = 0; i < _nrow; i++){
_diagI[i] = (i * (2*_nrow - i + 1))/2;
}
_a = (dataType*) calloc(_length, sizeof(dataType));
_atemp = (dataType*) calloc(_length, sizeof(dataType));
if (!_a || !_atemp) throw returnR("Out of memory in MatrixLT.cpp: MatrixLT::MatrixLT(nrow)", 99);
for (i = 0; i < _length; i++){
_a[i] = 0;
}
}
else{
_a = NULL;
_atemp = NULL;
_diagI = NULL;
}
} /** end of the parametric constructor 2 **/
//
// * use mean and mean +- 3*sd of the distribution [a[ia] | a[-ia], lambda]
// as starting abscissae
// * do not check whether they lie on both sides of the mode,
// this will be done always before sampling is done
//
void
Gspline2::find_start_abscis1()
{
if (_dim != 1){
throw returnR("Error in Gspline2_updateWeights.cpp: Gspline2::find_start_abscis1. Implemented only for UNIVARIATE G-splines", 1);
}
if (mcmc_Gspline2::_nabscis != 3){
throw returnR("Dear Arnost, please update Gspline2::find_start_abscis1() function after changing _nabscis ;-)", 1);
}
double mean, invvar, three_sd;
int K = _K.aconst()[0];
const double *aa = _a->aconst();
double *Abscis = _abscis->a();
for (int ia=-K; ia <= K; ia++){
this->full_a_pars1(&mean, &invvar, &ia, aa);
three_sd = 3/sqrt(invvar);
Abscis[0] = mean - three_sd;
Abscis[1] = mean;
Abscis[2] = mean + three_sd;
aa++;
Abscis += mcmc_Gspline2::_nabscis;
}
return;
}
MatrixLT<dataType>::MatrixLT(const MatrixLT<dataType>& A)
{
int i;
_nrow = A.nrow();
_length = A.length();
if (_length){
_diagI = (int*) calloc(_nrow, sizeof(int));
if (!_diagI) throw returnR("Out of memory in MatrixLT.cpp: MatrixLT::MatrixLT(A)", 99);
for (i = 0; i < _nrow; i++){
_diagI[i] = A.diagI(i);
}
_a = (dataType*) calloc(_length, sizeof(dataType));
_atemp = (dataType*) calloc(_length, sizeof(dataType));
if (!_a || !_atemp) throw returnR("Out of memory in MatrixLT.cpp: MatrixLT::MatrixLT(A)", 99);
for (i = 0; i < _length; i++){
_a[i] = A.a(i);
_atemp[i] = A._atemp[i];
}
}
else{
_a = NULL;
_atemp = NULL;
_diagI = NULL;
}
}
//
// Compute -0.5*sum (Delta a)^2 in the case of univariate CAR in each dimension
//
// penalty ....... either one-component or two-component array
// * if _equal_lambda then penalty[0] gives the sum of row- and column-penalties
//
void
Gspline::penalty_uniCAR() const
{
int ia, col, row;
double* Da;
switch (_dim){
/*** dimension = 1 ***/
case 1:
Da = new double[_length[0]];
if (Da == NULL) throw returnR("C++ Error: Could not allocate working memory", 1);
for (ia = 0; ia < _length[0]; ia++) Da[ia] = _a[ia];
diff(_order, _length[0], Da);
_penalty[0] = 0.0;
for (ia = 0; ia < _length[0] - _order; ia++) _penalty[0] += (Da[ia] * Da[ia]);
_penalty[0] *= (-0.5);
break;
/*** dimension = 2 ***/
case 2:
Da = new double[(_length[0] > _length[1] ? _length[0] : _length[1])];
if (Da == NULL) throw returnR("C++ Error: Could not allocate working memory", 1);
/* penalty over rows with fixed columns */
_penalty[0] = 0.0;
for (col = 0; col < _length[1]; col++){
for (row = 0; row < _length[0]; row++) Da[row] = _a[col*_length[0] + row];
diff(_order, _length[0], Da);
for (row = 0; row < _length[0] - _order; row++) _penalty[0] += (Da[row] * Da[row]);
}
_penalty[0] *= (-0.5);
/* penalty over cols with fixed rows */
_penalty[1] = 0.0;
for (row = 0; row < _length[0]; row++){
for (col = 0; col < _length[1]; col++) Da[col] = _a[col*_length[0] + row];
diff(_order, _length[1], Da);
for (col = 0; col < _length[1] - _order; col++) _penalty[1] += (Da[col] * Da[col]);
}
_penalty[1] *= (-0.5);
if (_equal_lambda) _penalty[0] += _penalty[1];
break;
default:
throw returnR("C++ Error: Strange _dim in Gspline::penalty_uniCAR", 1);
} /** end of switch (_dim) **/
delete [] Da;
return;
}
/*** =========================================================================== ***/
void
updateAfterChangeD(RandomEff32::RE *data)
{
static const double *cdP;
static double *dP;
static int i;
static int info[1];
/*** Covariance matrix -> inverse covariance matrix and its determinant ***/
cdP = data->_D;
dP = data->_Di;
for (i = 0; i < data->_lD; i++){
*dP = *cdP;
dP++;
cdP++;
}
AK_BLAS_LAPACK::chol_dpptrf(data->_Di, &data->_nRandom, info);
if (*info){
throw returnR("Error in structRandomEff32.cpp: updateAfterChangeD. Covariance matrix is not positive definite.", 1);
}
data->_detD = data->_Di[0] * data->_Di[0] * data->_Di[2] * data->_Di[2];
AK_BLAS_LAPACK::chol_dpptri(data->_Di, &data->_nRandom, info);
return;
}
void
MatrixLT<dataType>::mat2array(dataType* a, const int& type) const
{
int i, j;
const dataType* _aP = _a;
switch (type){
case 0:
for (i = 0; i < _length; i++){
a[i] = _a[i];
}
break;
case 1:
for (j = 0; j < _nrow; j++){
a[j*_nrow + j] = *_aP;
_aP++;
for (i = j+1; i < _nrow; i++){
a[j*_nrow + i] = *_aP;
a[i*_nrow + j] = *_aP;
_aP++;
}
}
break;
default:
throw returnR("MatrixLT.cpp: MatrixLT::mat2array(a, type) error. Unknown type argument", 1);
}
return;
}
/***** Copy constructor *****/
RandomPoiss::RandomPoiss(const RandomPoiss &P)
{
int i;
_p = P._p;
_nTheta = P._nTheta;
_N = P._N;
_ni = P._ni;
_max_ni = P._max_ni;
_n = P._n;
_REdist = P._REdist;
_prior_for_REMean = P._prior_for_REMean;
_prior_for_REInvVar = P._prior_for_REInvVar;
_Theta = P._Theta;
_ThetaBar = P._ThetaBar;
_Theta_REMean = P._Theta_REMean;
_PropTheta = P._PropTheta;
_REMean = P._REMean;
_REInvVar = P._REInvVar;
_REInvVarL = P._REInvVarL;
_REVar = P._REVar;
_REStdDev = P._REStdDev;
_REWMean = P._REWMean;
_PropMean = P._PropMean;
_U = P._U;
_I = P._I;
_REMeanPriorMean = P._REMeanPriorMean;
_REMeanPriorInvVar = P._REMeanPriorInvVar;
_REMeanPriorWMean = P._REMeanPriorWMean;
_REInvVarPriorDF = P._REInvVarPriorDF;
_REInvVarPriorInvScale = P._REInvVarPriorInvScale;
_eta = P._eta;
_Propeta = P._Propeta;
_x = P._x;
_work = P._work;
_work_rwishart = P._work_rwishart;
_work_invVarSlice = P._work_invVarSlice;
if (_nTheta && _n){
_xx = new MatrixLT<double>[_n];
if (!_xx) throw returnR("Out of memory in RandomPoiss.cpp: RandomPoiss::RandomPoiss(P)", 99);
for (i = 0; i < _n; i++){
_xx[i] = P._xx[i];
}
}
else{
_xx = NULL;
}
}
JNIEXPORT jint JNICALL Java_ispy_main_OpenCV_getR(JNIEnv* env, jobject thiz)
{
if(flag==1){
R=returnR();
}
return R;
}
MatrixLT<dataType>::MatrixLT(const int& nrow, const dataType* a, const int& type)
{
int i, j;
dataType *_aP;
if (nrow < 0) throw returnR("MatrixLT.cpp: MatrixLT::MatrixLT(nrow, a, type) error", 1);
_nrow = nrow;
_length = (_nrow * (_nrow+1))/2;
if (_length){
_diagI = (int*) calloc(_nrow, sizeof(int));
if (!_diagI) throw returnR("Out of memory in MatrixLT.cpp: MatrixLT::MatrixLT(nrow, a, type)", 99);
for (i = 0; i < _nrow; i++){
_diagI[i] = (i * (2*_nrow - i + 1))/2;
}
_a = (dataType*) calloc(_length, sizeof(dataType));
_atemp = (dataType*) calloc(_length, sizeof(dataType));
if (!_a || !_atemp) throw returnR("Out of memory in MatrixLT.cpp: MatrixLT::MatrixLT(nrow, a, type)", 99);
switch (type){
case 0:
for (i = 0; i < _length; i++){
_a[i] = a[i];
}
break;
case 1:
_aP = _a;
for (j = 0; j < _nrow; j++){
for (i = j; i < _nrow; i++){
*_aP = a[j*_nrow+i];
_aP++;
}
}
break;
default:
throw returnR("MatrixLT.cpp: MatrixLT::MatrixLT(nrow, a, type) error. Unknown type argument", 1);
}
}
else{
_a = NULL;
_atemp = NULL;
_diagI = NULL;
}
} /** end of the parametric constructor 1 **/
//
// Penalty for the eight neighbors system
// computed via sum of weighted squared pairwise differences
//
// penalty ..... one-component pointer
//
void
Gspline::penalty_eight_neighbors() const
{
int i, j;
if (_dim != 2) throw returnR("C++ Error: Strange _dim appeares in Gspline::penalty_eight_neighbors", 1);
int nr = _length[0]; /* this should be always at least 5 */
int nc = _length[1]; /* this should be always at least 5 */
_penalty[0] = 0.0;
// Neighbors of sites (i, 0)
// ===========================
/* neighbors of site (0, 0) */
_penalty[0] += (_a[0]-_a[1])*(_a[0]-_a[1]) + (_a[0]-_a[nr])*(_a[0]-_a[nr]) - (_a[0]-_a[nr+1])*(_a[0]-_a[nr+1]);
/* neighbors (not yet included) of sites (i, 0), i=1,...,nr-2 */
for (i = 1; i <= nr-2; i++){
_penalty[0] += 2*(_a[i]-_a[nr+i])*(_a[i]-_a[nr+i]) + (_a[i]-_a[i+1])*(_a[i]-_a[i+1])
- (_a[i]-_a[nr+i-1])*(_a[i]-_a[nr+i-1]) - (_a[i]-_a[nr+i+1])*(_a[i]-_a[nr+i+1]);
}
/* neighbors (not yet included) of site (nr-1, 0) */
_penalty[0] += (_a[nr-1]-_a[nr+nr-1])*(_a[nr-1]-_a[nr+nr-1]) - (_a[nr-1]-_a[nr+nr-2])*(_a[nr-1]-_a[nr+nr-2]);
// Neighbors (not yet included) of sites (i, j), j=1,...,nc-2
// ==========================================================
for (j = 1; j <= nc-2; j++){
/* neighbors (not yet included) of site (0, j) */
_penalty[0] += 2*(_a[j*nr]-_a[j*nr+1])*(_a[j*nr]-_a[j*nr+1]) + (_a[j*nr]-_a[(j+1)*nr])*(_a[j*nr]-_a[(j+1)*nr])
- (_a[j*nr]-_a[(j+1)*nr+1])*(_a[j*nr]-_a[(j+1)*nr+1]);
/* neighbors (not yet included) of sites (i, j), i=1,...,nr-2 */
for (i = 1; i <= nr-2; i++){
_penalty[0] += 2*((_a[j*nr+i]-_a[(j+1)*nr+i])*(_a[j*nr+i]-_a[(j+1)*nr+i]) + (_a[j*nr+i]-_a[j*nr+i+1])*(_a[j*nr+i]-_a[j*nr+i+1]))
- (_a[j*nr+i]-_a[(j+1)*nr+i-1])*(_a[j*nr+i]-_a[(j+1)*nr+i-1]) - (_a[j*nr+i]-_a[(j+1)*nr+i+1])*(_a[j*nr+i]-_a[(j+1)*nr+i+1]);
}
/* neighbors (not yet included) of site (nr-1, j) */
_penalty[0] += (_a[j*nr+nr-1]-_a[(j+1)*nr+nr-1])*(_a[j*nr+nr-1]-_a[(j+1)*nr+nr-1]) - (_a[j*nr+nr-1]-_a[(j+1)*nr+nr-2])*(_a[j*nr+nr-1]-_a[(j+1)*nr+nr-2]);
}
// Neighbors (not yet included) of sites (i, nc-1)
// ===============================================
/* neighbors (not yet included) of sites (i, nc-1), i=0,...,nr-2 */
for (i = 0; i <= nr-2; i++){
_penalty[0] += (_a[(nc-1)*nr+i]-_a[(nc-1)*nr+i+1])*(_a[(nc-1)*nr+i]-_a[(nc-1)*nr+i+1]);
}
_penalty[0] *= (-0.5);
return;
}
MatrixLT<dataType>::MatrixLT(const int& nrow, const dataType* b)
{
int i, j;
const dataType *b1, *b2;
dataType *aP;
if (nrow < 0) throw returnR("MatrixLT.cpp: MatrixLT::MatrixLT(nrow, b) error", 1);
_nrow = nrow;
_length = (_nrow * (_nrow+1))/2;
if (_length){
_diagI = (int*) calloc(_nrow, sizeof(int));
if (!_diagI) throw returnR("Out of memory in MatrixLT.cpp: MatrixLT::MatrixLT(nrow, b)", 99);
for (i = 0; i < _nrow; i++){
_diagI[i] = (i * (2*_nrow - i + 1))/2;
}
_a = (dataType*) calloc(_length, sizeof(dataType));
_atemp = (dataType*) calloc(_length, sizeof(dataType));
if (!_a || !_atemp) throw returnR("Out of memory in MatrixLT.cpp: MatrixLT::MatrixLT(nrow, b)", 99);
b2 = b;
aP = _a;
for (j = 0; j < _nrow; j++){
b1 = b + j;
for (i = j; i < _nrow; i++){
*aP = (*b1) * (*b2);
aP++;
b1++;
}
b2++;
}
}
else{
_a = NULL;
_atemp = NULL;
_diagI = NULL;
}
} /** end of the parametric constructor 3 **/
//
// Compute ordered differences (diff_in_R is a version which can be called directly from R)
//
// order ..... order of the differences (at least 1)
// na ........ length of the whole vector 'a'
// Da ........ INPUT: vector for which differences should be computed
// OUTPUT: computed differences (at places 0, ..., la-1-order)
//
void
diff(const int& order, const int& na, double* Da)
{
int i;
if (order < 0 || order > na-1) throw returnR("C++ Error: order must be >= 0 & <= length(a) in diff", 1);
if (order == 0) return;
else{
for (i = 1; i < na; i++) Da[i-1] = Da[i] - Da[i-1];
diff(order-1, na-1, Da);
}
return;
}
// ======================================================================================
// ******* evalKendallTau
// ======================================================================================
void
evalKendallTau(double* value, const int* dim, const int* k_effect, const double* w, int** ind_mu, double**** PhiPhi)
{
static int pp, qq;
static int* ip;
static int* jp;
static int* kp;
static int* lp;
static const double* wp;
static const double* wq;
static double w_w;
if (*dim != 2) throw returnR("Function 'evalKendallTau' implemented only for dim = 2", 1);
*value = 0.0;
ip = ind_mu[0];
jp = ind_mu[1];
wp = w;
for (pp = 0; pp < *k_effect; pp++){
w_w = (*wp) * (*wp);
*value += w_w * PhiPhi[*ip][*jp][*ip][*jp];
kp = ip + 1;
lp = jp + 1;
wq = wp + 1;
for (qq = pp+1; qq < *k_effect; qq++){
w_w = (*wp) * (*wq);
*value += w_w * PhiPhi[*ip][*jp][*kp][*lp];
*value += w_w * PhiPhi[*kp][*lp][*ip][*jp];
kp++;
lp++;
wq++;
}
ip++;
jp++;
wp++;
}
*value *= 4;
*value -= 1;
return;
}
/*** =========================================================================== ***/
void
predict_db(RandomEff32::RE *data)
{
static const double *cdP;
static double *dP, *bP;
static int i, cl;
static int info[1];
/*** Covariance matrix -> Cholesky decomposition ***/
cdP = data->_D;
dP = data->_propVar;
for (i = 0; i < data->_lD; i++){
*dP = *cdP;
dP++;
cdP++;
}
AK_BLAS_LAPACK::chol_dpptrf(data->_propVar, &data->_nRandom, info);
if (*info){
throw returnR("Error in structRandomEff32.cpp: predict_db. Covariance matrix is not positive definite.", 1);
}
/*** Mean ***/
data->_propMean[0] = 0;
data->_propMean[1] = 0;
/*** Sample ***/
dP = data->_d;
bP = data->_b;
for (cl = 0; cl < data->_nCluster; cl++){
Mvtdist3::rmvnorm2006(data->_propValue, data->_propMean, data->_propVar, &data->_nRandom);
*dP = data->_propValue[0];
*bP = data->_propValue[1];
dP++;
bP++;
}
return;
}
//
// data: Initialized structure
//
// dVal: Initial values of the onset random intercept
// See 'priorb1D' argument of bayessurvreg2 function
//
// bVal: Initial values of the time-to-event random intercept
// See 'priorb2D' argument of bayessurvreg2 function
//
// parD[4]: parD[0,1,2] = initial value of var(d,b) = D (lower triangle)
// parD[3] = prior degrees of freedom of the Wishart prior
// parD[4,5,6] = prior scale matrix of the Wishart prior (lower triangle)
//
// pardI: Integer parameters for the onset random intercept
// See 'priorb1I' argument of bayessurvreg2 function
// parI[0] = type of prior (0 = Normal, 1 = Gspline), it MUST BE 0
// parI[1] = number of random effects, it MUST BE 1
// parI[2] = number of clusters
// parI[3,...2+nCluster] = numbers of observations within each cluster
//
// parbI: Integer parameters for the time-to-event random intercept
// Structure the same as for pardI
//
//
void
init(RandomEff32::RE *data, double *dVal, double *bVal, double *parD, const int *pardI, const int *parbI)
{
int i, info;
const int *nCld, *nClb;
const double *cdP;
double *dP;
/*** Type of the distribution of random effects ***/
if (pardI[0] != 0 || parbI[0] != 0){
throw returnR("Error in structRandomEff32.cpp: init. Type of prior of random effects must me 0 (normal).", 1);
}
/*** Dimension of the random effects ***/
if (pardI[1] != 1 || parbI[1] != 1){
throw returnR("Error in structRandomEff32.cpp: init. There must be exactly 1 random effect in each part of the model.", 1);
}
data->_nRandom = pardI[1] + parbI[1];
data->_lD = (data->_nRandom * (data->_nRandom + 1))/2;
/*** Number of clusters ***/
if (pardI[2] <= 0 || parbI[2] <= 0 || pardI[2] != parbI[2]){
throw returnR("Error in structRandomEff32.cpp: init. Number of clusters must be positive and the same in both parts of the model.", 1);
}
data->_nCluster = pardI[2];
/*** Numbers of observations within each cluster ***/
nCld = pardI + 3;
nClb = parbI + 3;
for (i = 0; i < data->_nCluster; i++){
if (*nCld <= 0 || *nClb <= 0 || *nCld != *nClb){
throw returnR("Error in structRandomEff32.cpp: init. Numbers of observations within each clusters must be positive and the same in both part sof the model.", 1);
}
nCld++;
nClb++;
}
data->_nwithinCl = pardI + 3;
/*** Values of random effects ***/
data->_d = dVal;
data->_b = bVal;
/*** Value of the covariance matrix of random effects ***/
data->_D = parD;
/*** Covariance matrix -> its determinant and inverse ***/
cdP = data->_D;
dP = data->_Di;
for (i = 0; i < data->_lD; i++){
*dP = *cdP;
dP++;
cdP++;
}
AK_BLAS_LAPACK::chol_dpptrf(data->_Di, &data->_nRandom, &info);
if (info){
throw returnR("Error in structRandomEff32.cpp: init. Initial covariance matrix is not positive definite.", 1);
}
data->_detD = data->_Di[0] * data->_Di[0] * data->_Di[2] * data->_Di[2];
AK_BLAS_LAPACK::chol_dpptri(data->_Di, &data->_nRandom, &info);
/*** Parameters of the prior of the covariance matrix of random effects ***/
/** Degrees of freedom **/
if (parD[3] <= data->_nRandom - 1){
throw returnR("Error in structRandomEff32.cpp: init. Prior Wishart degrees of freedom must be higher than 1.", 1);
}
data->_priorDF = parD[3];
/** Scale matrix -> inverse scale matrix **/
cdP = parD + 4;
dP = data->_priorSi;
for (i = 0; i < data->_lD; i++){
*dP = *cdP;
dP++;
cdP++;
}
AK_BLAS_LAPACK::chol_dpptrf(data->_priorSi, &data->_nRandom, &info);
if (info){
throw returnR("Error in structRandomEff32.cpp: init. Prior Wishart scale matrix is not positive definite.", 1);
}
AK_BLAS_LAPACK::chol_dpptri(data->_priorSi, &data->_nRandom, &info);
/** Degrees of freedom of the full conditional of the covariance matrix of random effects **/
data->_propDF = data->_priorDF + data->_nCluster;
return;
}
// ****** 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 ***/
// ****** 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 ***/
//
// alloc[this->_N]: vector of single index (0,...,Gspl->total_length-1) allocations
//
void
RandomPoiss::updateRE2Bi(int *accept, double *ll,
double *mu, double *Propmu,
const BiGspline2 *Gspl,
const double *offset, const int *y, const double *log_y_factor,
const MatrixRect<int> *alloc)
{
static int i, length0, i0, i1;
static double llCl;
const int *yP, *niP, *allocP;
const double *log_y_factorP, *xP, *offsetP, *REMeanP, *inv_sigma2_d2P, *d_knotsP0, *d_knotsP1;
const MatrixLT<double> *xxP;
int *acceptP;
double *muP, *thetaP, *etaP, *meanP, *REWMeanP;
if (_nTheta != BiGspline2A::_dim){
REprintf("_nTheta=%d, BiGspline2A::_dim=%d\n", _nTheta, BiGspline2A::_dim);
throw returnR("Error in RandomPoiss.cpp: updateRE2Bi(). Not implemented for this dimension.", 1);
}
*ll = 0;
acceptP = accept;
yP = y;
log_y_factorP = log_y_factor;
muP = mu;
thetaP = _Theta.a();
etaP = _eta.a();
offsetP = offset;
xP = _x.aconst();
xxP = _xx;
niP = _ni.aconst();
allocP = alloc->aconst();
REMeanP = _REMean.aconst(); /*** constant over cycles of the loop over observations ***/
meanP = _ThetaBar.a(); /*** working space at each cycle of the loop ***/
REWMeanP = _REWMean.a(); /*** working space at each cycle of the loop ***/
length0 = Gspl->lengthconst()[0];
d_knotsP0 = Gspl->d_knotsconst()[0].aconst();
d_knotsP1 = Gspl->d_knotsconst()[1].aconst();
inv_sigma2_d2P = Gspl->inv_sigma2_d2const();
for (i = 0; i < _N; i++){
/*** Mean of the random effect given allocation, store it in _ThetaBar. ***/
i0 = *allocP % length0;
i1 = *allocP / length0;
meanP[0] = REMeanP[0] + d_knotsP0[i0];
meanP[1] = REMeanP[1] + d_knotsP1[i1];
/*** Update _REWMean = (d*sigma)^{-2}*(intcpt + d*knot[alloc]). ***/
REWMeanP[0] = inv_sigma2_d2P[0] * meanP[0];
REWMeanP[1] = inv_sigma2_d2P[1] * meanP[1];
/*** Sample new value of the random effect ***/
mcmc_common::update_reg_gamermanPoiss(acceptP, &llCl, _U.a(), _I.a(),
etaP, _Propeta.a(), muP, Propmu, _work.a(),
offsetP, thetaP, _PropTheta.a(), yP, log_y_factorP, xP, xxP,
*niP, _p, meanP, REWMeanP, inv_sigma2_d2P, NULL, true, _PropMean.a(),
"RandomPoiss::updateRE2Bi");
*ll += llCl;
/*** Increase pointers ***/
acceptP++;
yP += (*niP);
log_y_factorP += (*niP);
muP += (*niP);
thetaP += _nTheta;
etaP += (*niP);
offsetP += (*niP);
xP += _p * (*niP);
xxP += (*niP);
niP++;
allocP++;
}
return;
}
/* ------------------------------------------------------------------------------------------------------------------------ */
void
RandomPoiss::updateRE2(int *accept, double *ll,
double *mu, double *Propmu,
const Gspline2 *Gspl,
const double *offset, const int *y, const double *log_y_factor,
const MatrixRect<int> *alloc)
{
static int i;
static double llCl;
const int *yP, *niP, *allocP, *KP;
const double *log_y_factorP, *xP, *offsetP, *REMeanP, *inv_sigma2_d2P, *d_knotsP;
const MatrixLT<double> *xxP;
const MatrixRect<double> *d_knotsM;
int *acceptP;
double *muP, *thetaP, *etaP, *meanP, *REWMeanP;
*ll = 0;
acceptP = accept;
yP = y;
log_y_factorP = log_y_factor;
muP = mu;
thetaP = _Theta.a();
etaP = _eta.a();
offsetP = offset;
xP = _x.aconst();
xxP = _xx;
niP = _ni.aconst();
allocP = alloc->aconst();
REMeanP = _REMean.aconst(); /*** constant over cycles of the loop over observations ***/
meanP = _ThetaBar.a(); /*** working space at each cycle of the loop ***/
REWMeanP = _REWMean.a(); /*** working space at each cycle of the loop ***/
switch(_nTheta){
case 0:
return;
/*** UNIVARIATE random effects ***/
/*** ========================= ***/
case 1:
KP = Gspl->KAconst();
d_knotsM = Gspl->d_knotsconst();
d_knotsP = d_knotsM->aconst();
inv_sigma2_d2P = Gspl->inv_sigma2_d2Aconst();
//Rprintf("d_knotsP: "); d_knotsM->print(0);
//Rprintf("REMeanP: %g\n\n", *REMeanP);
for (i = 0; i < _N; i++){
/*** Mean of the random effect given allocation, store it in _ThetaBar. ***/
*meanP = *REMeanP + d_knotsP[*allocP + (*KP)];
/*** Update _REWMean = (d*sigma)^{-2}*(intcpt + d*knot[alloc]). ***/
*REWMeanP = *inv_sigma2_d2P * (*meanP);
/*** Sample new value of the random effect ***/
mcmc_common::update_reg_gamermanPoiss(acceptP, &llCl, _U.a(), _I.a(),
etaP, _Propeta.a(), muP, Propmu, _work.a(),
offsetP, thetaP, _PropTheta.a(), yP, log_y_factorP, xP, xxP,
*niP, _p, meanP, REWMeanP, inv_sigma2_d2P, NULL, true, _PropMean.a(),
"RandomPoiss::updateRE2");
*ll += llCl;
/*** Increase pointers ***/
acceptP++;
yP += (*niP);
log_y_factorP += (*niP);
muP += (*niP);
thetaP += _nTheta;
etaP += (*niP);
offsetP += (*niP);
xP += _p * (*niP);
xxP += (*niP);
niP++;
allocP += _nTheta;
}
return;
/*** BIVARIATE random effects (copula???) ***/
/*** ==================================== ***/
case 2:
throw returnR("Error in RandomPoiss.cpp: RandomPoiss::updateRE2. Not implemented for _nTheta = 2", 1);
return;
/*** MULTI(>2)VARIATE random effects ***/
/*** =============================== ***/
default:
throw returnR("Error in RandomPoiss.cpp: RandomPoiss::updateRE2. Not implemented for _nTheta > 2", 1);
return;
}
}
void
writeTwoToFile(const dd1* array1, const int& nR1, const int& nC1, const int& col1,
const dd2* array2, const int& nR2, const int& nC2,
const std::string& dir, const std::string& filename, const char &flag,
const int& prec, const int& width)
{
try{
if (nR1 != nR2) throw returnR("C++ programming error: contact the author", 99);
std::string path = dir + filename;
std::ofstream out;
openFile(out, path, flag);
std::ostringstream s;
unsigned int mlen = width;
/* Passes up to 5 rows of the second array to get things to line up nicely */
for (int i = 0; i < nR2 && i < 5; i++) {
for (int j = 0; j < nC2; j++) {
s.str("");
if (array2[i*nC2 + j] >= FLT_MAX){
s << std::setw(width)
<< std::setiosflags(std::ios::fixed)
<< "1e50" << " ";
}
else{
if (array2[i*nC2 + j] < 1 && array2[i*nC2 + j] > -1)
s << std::scientific << std::setw(width) << std::setprecision(prec) << array2[i*nC2 + j] << " ";
else
s << std::fixed << std::setw(width) << std::setprecision(prec) << array2[i*nC2 + j] << " ";
}
if (s.str().length() > mlen) mlen = s.str().length();
}
}
/* Write to files */
// s.str("");
for (int i = 0; i < nR1; i++) {
if (array1[i*nC1 + col1] >= FLT_MAX){
out << std::setw(mlen) << "1e50";
out << " ";
}
else{
if (array1[i*nC1 + col1] < 1 && array1[i*nC1 + col1] > -1){
out << std::scientific << std::setw(mlen) << std::setprecision(prec) << array1[i*nC1 + col1];
out << " ";
}
else{
out << std::fixed << std::setw(mlen) << std::setprecision(prec) << array1[i*nC1 + col1];
out << " ";
}
}
for (int j = 0; j < nC2; j++){
if (array2[i*nC2 + j] >= FLT_MAX){
out << std::setw(mlen) << "1e50";
out << " ";
}
else{
if (array2[i*nC2 + j] < 1 && array2[i*nC2 + j] > -1){
out << std::scientific << std::setw(mlen) << std::setprecision(prec) << array2[i*nC2 + j];
out << " ";
}
else{
out << std::fixed << std::setw(mlen) << std::setprecision(prec) << array2[i*nC2 + j];
out << " ";
}
}
}
out << std::endl;
}
// out << s.str();
out.close();
return;
} // end of try
catch(returnR){
throw;
}
} // end of function writeTwoToFile
RandomPoiss::RandomPoiss(const int &p, const int &N, const int *ni,
const double *theta, const double *mean_ivar,
const int &REdist, const int *mean_ivarPrior, const double *meanPrior, const double *ivarPrior,
const double *x)
{
int i, j;
const double *xP, *cdP;
double *dP;
int LTp;
/*** _p, _N, _ni, _max_ni, _n ***/
/*** ======================== ***/
_p = p;
_N = N;
if (_N){
_ni = MatrixRect<int>(1, _N, ni);
if (_ni.anyNonNeg()) throw returnR("Error in RandomPoiss.cpp: RandomPoiss::RandomPoiss(...), N > 0 & any ni <= 0", 1);
_max_ni = _ni.max();
_n = _ni.sum();
}
else{
_max_ni = 0;
_n = 0;
}
/*** _nTheta, _work ***/
/*** ================== ***/
_nTheta = _p;
LTp = (_p*(1+_p))/2;
if (LTp) _work = MatrixRect<double>(1, LTp);
else _work = MatrixRect<double>(1, 1);
/*** _REdist ***/
/*** ======= ***/
switch (REdist){
case mcmc_Random::_None:
case mcmc_Random::_Normal:
case mcmc_Random::_Gspline:
_REdist = REdist;
break;
default:
throw returnR("Error in RandomPoiss.cpp: RandomPoiss::RandomPoiss(...), incorrect REdist argument", 1);
}
if (_nTheta){
/*** _ThetaBar, _PropTheta, _PropMean ***/
/*** ================================ ***/
_ThetaBar = MatrixRect<double>(1, _nTheta);
_PropTheta = MatrixRect<double>(1, _nTheta);
_PropMean = MatrixRect<double>(1, _nTheta);
/*** _REMean, _REInvVar, _REInvVarL, _REVar, _REWMean, _U, _I ***/
/*** ======================================================== ***/
_REMean = MatrixRect<double>(1, _nTheta, mean_ivar);
_REInvVar = MatrixLT<double>(_nTheta, mean_ivar+_nTheta, 0);
if (mean_ivarPrior[1] == mcmc_Random::_SDUnif || mean_ivarPrior[1] == mcmc_Random::_GammaIndep){ /*** _REInvVar should be diagonal ***/
dP = _REInvVar.a();
for (j = 0; j < _nTheta; j++){
dP++;
for (i = j+1; i < _nTheta; i++){
*dP = 0.0;
dP++;
}
}
}
_REInvVarL = _REInvVar;
i = _REInvVarL.cholesky(0);
if (i < _nTheta){
Rprintf("WARNING: RandomPoiss.cpp: RandomPoiss::RandomPoiss(...), supplied _REInvVar is not of full rank\n");
Rprintf("_REInvVar:\n");
_REInvVar.print(0);
}
_REVar = _REInvVarL;
_REVar.chinv(0);
_REStdDev = MatrixRect<double>(1, _nTheta);
_REVar.sqrtDiag(_REStdDev.a());
_REWMean = MatrixRect<double>(1, _nTheta);
Ab2(_REWMean.a(), &_REInvVar, _REMean.aconst());
_U = MatrixRect<double>(1, _nTheta);
_I = MatrixLT<double>(_nTheta);
/*** _prior_for_REMean, _REMeanPriorMean, _REMeanPriorInvVar, _REMeanPriorWMean ***/
/*** ========================================================================== ***/
switch (mean_ivarPrior[0]){
case mcmc_Random::_Fixed_:
_prior_for_REMean = mcmc_Random::_Fixed_;
_REMeanPriorMean = MatrixRect<double>(1, _nTheta);
_REMeanPriorInvVar = MatrixRect<double>(1, _nTheta);
_REMeanPriorWMean = MatrixRect<double>(1, _nTheta);
break;
case mcmc_Random::_Normal_:
_prior_for_REMean = mcmc_Random::_Normal_;
_REMeanPriorMean = MatrixRect<double>(1, _nTheta, meanPrior);
_REMeanPriorInvVar = MatrixRect<double>(1, _nTheta, meanPrior+_nTheta);
_REMeanPriorWMean = MatrixRect<double>(1, _nTheta, meanPrior+_nTheta, meanPrior, 1);
break;
default:
throw returnR("Error in RandomPoiss.cpp: RandomPoiss::RandomPoiss(...), incorrect mean_ivarPrior argument", 1);
}
/*** _prior_for_REInvVar, _REInvVarPriorDF, _REInvVarPriorInvScale, _work_rwishart, _work_invVarSlice ***/
/*** ================================================================================================ ***/
switch (mean_ivarPrior[1]){
case mcmc_Random::_Fixed:
_prior_for_REInvVar = mcmc_Random::_Fixed;
_REInvVarPriorDF = MatrixRect<double>(1, 1);
_REInvVarPriorInvScale = MatrixLT<double>(_nTheta);
break;
case mcmc_Random::_Wishart:
_prior_for_REInvVar = mcmc_Random::_Wishart;
_REInvVarPriorDF = MatrixRect<double>(1, 1, ivarPrior);
_REInvVarPriorInvScale = MatrixLT<double>(_nTheta, ivarPrior+1, 0);
break;
case mcmc_Random::_SDUnif:
_prior_for_REInvVar = mcmc_Random::_SDUnif;
_REInvVarPriorDF = MatrixRect<double>(1, 1);
_REInvVarPriorInvScale = MatrixLT<double>(_nTheta);
cdP = ivarPrior;
dP = _REInvVarPriorInvScale.a();
for (i = 0; i < _nTheta; i++){
*dP = 1/((*cdP)*(*cdP));
dP++;
cdP++;
}
break;
case mcmc_Random::_GammaIndep:
_prior_for_REInvVar = mcmc_Random::_GammaIndep;
_REInvVarPriorDF = MatrixRect<double>(1, _nTheta, ivarPrior);
_REInvVarPriorInvScale = MatrixLT<double>(_nTheta);
cdP = ivarPrior + _nTheta;
dP = _REInvVarPriorInvScale.a();
for (i = 0; i < _nTheta; i++){
*dP = *cdP;
dP++;
cdP++;
}
break;
default:
throw returnR("Error in RandomPoiss.cpp: RandomPoiss::RandomPoiss(...), incorrect mean_ivarPrior argument", 1);
}
_work_rwishart = MatrixRect<double>(1, 2*_nTheta*_nTheta);
//_work_rwishart = MatrixRect<double>(1, 2*_I.length() + _nTheta*_nTheta); /* changed on 12/01/2007 */
_work_invVarSlice = MatrixRect<double>(1, 4*_nTheta);
if (_N){
/*** _Theta, _Theta_REMean ***/
/*** ===================== ***/
_Theta = MatrixRect<double>(_nTheta, _N, theta);
_Theta.mean(_ThetaBar.a(), 1);
_Theta_REMean = MatrixRect<double>(_nTheta, _N, theta);
NSampleVar(&_I, _Theta_REMean.a(), _Theta.aconst(), _REMean.aconst(), _N);
/*** _x,_eta, _Propeta ***/
/*** ================= ***/
_x = MatrixRect<double>(_p, _n, x);
_eta = MatrixRect<double>(1, _n);
_Propeta = MatrixRect<double>(1, _max_ni);
if (_p){
_eta.BAcolProd(&_Theta, &_ni, &_x, 0);
}
/*** _xx ***/
/*** ====***/
_xx = new MatrixLT<double>[_n];
if (!_xx) throw returnR("Out of memory in RandomPoiss.cpp: RandomPoiss::RandomPoiss(...)", 99);
xP = x;
for (i = 0; i < _n; i++){
_xx[i] = MatrixLT<double>(_p, xP);
xP += _p;
}
}
}
else{ /*** else from if (_nTheta) ***/
if (_N) _eta = MatrixRect<double>(1, _n);
}
if (!_nTheta || !_n){
_xx = NULL;
}
}
/***** Assignment operator *****/
BetaGammaExtend&
BetaGammaExtend::operator=(const BetaGammaExtend& bg)
{
int i;
if (!_nbeta && _randomIntcpt){
free(_indbinXA);
}
if (_nbeta){
free(_indbA);
free(_beta); free(_priorMean); free(_priorSD); free(_priorInvVar);
if (_nFixed){
free(_indFixed);
free(_meanFixed); free(_meanFixedTemp); free(_covFixed); free(_ichicovFixed); free(_diagIFixed);
}
if (_ngamma){
free(_indgamma);
free(_meangamma); free(_meangammaTemp); free(_covgamma); free(_ichicovgamma); free(_diagIgamma);
free(_sumbM); free(_indRandomUpdate);
if (_nRandom > _ngamma){
free(_sumgammab); free(_indRandomKeep);
}
}
if (_nRandom){
free(_indbinXA);
}
}
if (bg.nbeta() == 0){
_nbeta =_nFixed = _ngamma = 0;
_indbA = _indFixed = NULL;
_beta = _priorMean = _priorSD = _priorInvVar = NULL;
_lcovFixed = 0; _meanFixed = _meanFixedTemp = _covFixed = _ichicovFixed = NULL; _diagIFixed = NULL;
_lcovgamma = 0; _meangamma = _meangammaTemp = _covgamma = _ichicovgamma = NULL; _diagIgamma = NULL;
_sumbM = _sumgammab = NULL;
_indRandomUpdate = _indRandomKeep = NULL;
_randomIntcpt = bg.randomIntcpt();
_nRandom = bg.nRandom();
if (_randomIntcpt){
_indbinXA = (int*) malloc(sizeof(int));
if (!_indbinXA) throw returnR("Not enough memory available in BetaGamma assignment operator (_indbinXA)", 1);
*_indbinXA = -1;
}
else{
_indbinXA = NULL;
}
}
else{
_nbeta = bg.nbeta();
_nFixed = bg.nFixed();
_ngamma = bg.ngamma();
_randomIntcpt = bg.randomIntcpt();
_nRandom = bg.nRandom();
_indbA = (int*) calloc(_nbeta, sizeof(int));
if (!_indbA) throw returnR("Not enough memory available in BetaGamma assignment operator (_indbA)", 1);
for (i = 0; i < _nbeta; i++){
_indbA[i] = bg._indbA[i];
}
if (_nFixed > 0){
_indFixed = (int*) calloc(_nFixed, sizeof(int));
if (!_indFixed) throw returnR("Not enough memory available in BetaGamma assignment operator (_indFixed)", 1);
for (i = 0; i < _nFixed; i++) _indFixed[i] = bg._indFixed[i];
}
if (_ngamma){
_indgamma = (int*) calloc(_ngamma, sizeof(int));
if (!_indgamma) throw returnR("Not enough memory available in BetaGamma assignment operator (_indgamma)", 1);
for (i = 0; i < _ngamma; i++) _indgamma[i] = bg._indgamma[i];
}
if (_nRandom > 0){
_indbinXA = (int*) calloc(_nRandom, sizeof(int));
if (!_indbinXA) throw returnR("Not enough memory available in BetaGamma copy constructor (_indbinXA)", 1);
for (i = 0; i < _nRandom; i++) _indbinXA[i] = bg._indbinXA[i];
}
_beta = (double*) calloc(_nbeta, sizeof(double));
_priorMean = (double*) calloc(_nbeta, sizeof(double));
_priorSD = (double*) calloc(_nbeta, sizeof(double));
_priorInvVar = (double*) calloc(_nbeta, sizeof(double));
if (!_beta) throw returnR("Not enough memory available in BetaGamma assignment operator (_beta)", 1);
if (!_priorMean || !_priorSD || !_priorInvVar) throw returnR("Not enough memory available in BetaGamma assign. oper. (_prior*)", 1);
for (i = 0; i < _nbeta; i++){
_beta[i] = bg.beta(i);
_priorMean[i] = bg.priorMean(i);
_priorSD[i] = bg.priorSD(i);
_priorInvVar[i] = bg.priorInvVar(i);
}
_lcovFixed = bg.lcovFixed();
if (_nFixed){
_meanFixed = (double*) calloc(_nFixed, sizeof(double));
_meanFixedTemp = (double*) calloc(_nFixed, sizeof(double));
if (!_meanFixed || !_meanFixedTemp) throw returnR("Not enough memory available in BetaGamma assignment operator (_meanFixed*)", 1);
for (i = 0; i < _nFixed; i++){
_meanFixed[i] = bg._meanFixed[i];
_meanFixedTemp[i] = bg._meanFixedTemp[i];
}
_covFixed = (double*) calloc(_lcovFixed, sizeof(double));
_ichicovFixed = (double*) calloc(_lcovFixed, sizeof(double));
if (!_covFixed || !_ichicovFixed) throw returnR("Not enough memory available in BetaGamma assignment operator (_*covFixed)", 1);
for (i = 0; i < _lcovFixed; i++){
_covFixed[i] = bg._covFixed[i];
_ichicovFixed[i] = bg._ichicovFixed[i];
}
_diagIFixed = (int*) calloc(_nFixed, sizeof(int));
if (!_diagIFixed) throw returnR("Not enough memory available in BetaGamma assignment operator (_diagIFixed)", 1);
for (i = 0; i < _nFixed; i++) _diagIFixed[i] = bg._diagIFixed[i];
}
else{
_meanFixed = _meanFixedTemp = _covFixed = _ichicovFixed = NULL;
_diagIFixed = NULL;
}
_lcovgamma = bg.lcovgamma();
if (_ngamma){
_meangamma = (double*) calloc(_ngamma, sizeof(double));
_meangammaTemp = (double*) calloc(_ngamma, sizeof(double));
if (!_meangamma || !_meangammaTemp) throw returnR("Not enough memory available in BetaGamma assignment operator (_meangamma*)", 1);
for (i = 0; i < _ngamma; i++){
_meangamma[i] = bg._meangamma[i];
_meangammaTemp[i] = bg._meangammaTemp[i];
}
_covgamma = (double*) calloc(_lcovgamma, sizeof(double));
_ichicovgamma = (double*) calloc(_lcovgamma, sizeof(double));
if (!_covgamma || !_ichicovgamma) throw returnR("Not enough memory available in BetaGamma assignment operator (_*covgamma)", 1);
for (i = 0; i < _lcovgamma; i++){
_covgamma[i] = bg._covgamma[i];
_ichicovgamma[i] = bg._ichicovgamma[i];
}
_diagIgamma = (int*) calloc(_ngamma, sizeof(int));
if (!_diagIgamma) throw returnR("Not enough memory available in BetaGamma assignment operator (_diagIgamma)", 1);
for (i = 0; i < _ngamma; i++) _diagIgamma[i] = bg._diagIgamma[i];
_sumbM = (double*) calloc(_ngamma, sizeof(double));
_indRandomUpdate = (int*) calloc(_ngamma, sizeof(int));
if (!_sumbM || !_indRandomUpdate) throw returnR("Not enough memory available in BetaGamma copy const. (_sumbM/_indRandomUpdate)", 1);
for (i = 0; i < _ngamma; i++){
_sumbM[i] = bg._sumbM[i];
_indRandomUpdate[i] = bg._indRandomUpdate[i];
}
if (_nRandom > _ngamma){
_sumgammab = (double*) calloc(_nRandom - _ngamma, sizeof(double));
_indRandomKeep = (int*) calloc(_nRandom - _ngamma, sizeof(int));
if (!_sumgammab || !_indRandomKeep) throw returnR("Not enough memory avail. in BetaGamma copy con. (_sumgammab/_indRandomKeep)", 1);
_sumgammab[0] = bg._sumgammab[0]; // _nRandom - _ngamma must be equal to 1
_indRandomKeep[0] = bg._indRandomKeep[0]; // this must be an index of the random intercept
}
else{
_sumgammab = NULL;
_indRandomKeep = NULL;
}
}
else{
_meangamma = _meangammaTemp = _covgamma = _ichicovgamma = NULL;
_diagIgamma = NULL;
_sumbM = _sumgammab = NULL;
_indRandomUpdate = _indRandomKeep = NULL;
}
}
return *this;
} /** end of the assignment operator **/
//
// mean: Computed mean of the full conditional distribution
// invvar: Computed inverse variance of the full conditional distribution
//
// ia: Index of the a that is updated (on the scale -K,...,K)
// aa: Pointer to _a that is updated
//
void
Gspline2::full_a_pars1(double* mean, double* invvar, const int *ia, const double *aa) const
{
int K = _K.aconst()[0];
if (*ia < -K || *ia > K){
REprintf("K=%d, ia=%d\n", K, *ia);
throw returnR("Error in Gspline2_updateWeights: Gspline2::full_a_pars1(). Argument ia out of the range", 1);
}
switch (_order.aconst()[0]){
case 1:
if (*ia > -K && *ia < K){
*mean = (aa[-1] + aa[1])/2;
*invvar = 2*_lambda.aconst()[0];
}
else{ // ia = -K or K
if (*ia == -K) *mean = aa[1];
else *mean = aa[-1];
*invvar = _lambda.aconst()[0];
}
return;
case 2:
if (*ia >= -K+2 && *ia <= K-2){
*mean = (-aa[-2] + 4*aa[-1] + 4*aa[1] - aa[2])/6;
*invvar = 6*_lambda.aconst()[0];
}
else{
if (*ia == -K+1 || *ia == K-1){
if (*ia == -K+1) *mean = (2*aa[-1] + 4*aa[1] - aa[2])/5;
else *mean = (-aa[-2] + 4*aa[-1] + 2*aa[1])/5;
*invvar = 5*_lambda.aconst()[0];
}
else{ // ia = -K or K
if (*ia == -K) *mean = 2*aa[1] - aa[2];
else *mean = -aa[-2] + 2*aa[-1];
*invvar = _lambda.aconst()[0];
}
}
return;
case 3:
if (*ia >= -K+3 && *ia <= K-3){
*mean = (aa[-3] - 6*aa[-2] + 15*aa[-1] + 15*aa[1] - 6*aa[2] + aa[3])/20;
*invvar = 20*_lambda.aconst()[0];
}
else{
if (*ia == -K+2 || *ia == K-2){
if (*ia == -K+2) *mean = (-3*aa[-2] + 12*aa[-1] + 15*aa[1] - 6*aa[2] + aa[3])/19;
else *mean = (aa[-3] - 6*aa[-2] + 15*aa[-1] + 12*aa[1] - 3*aa[2])/19;
*invvar = 19*_lambda.aconst()[0];
}
else{
if (*ia == -K+1 || *ia == K-1){
if (*ia == -K+1) *mean = (3*aa[-1] + 12*aa[1] - 6*aa[2] + aa[3])/10;
else *mean = (aa[-3] - 6*aa[-2] + 12*aa[-1] + 3*aa[1])/10;
*invvar = 10*_lambda.aconst()[0];
}
else{ // ia = -K or K
if (*ia == -K) *mean = 3*aa[1] - 3*aa[2] + aa[3];
else *mean = aa[-3] - 3*aa[-2] + 3*aa[-1];
*invvar = _lambda.aconst()[0];
}
}
}
return;
default:
REprintf("_order=%d\n", _order.aconst()[0]);
throw returnR("Error in Gspline2_updateWeights: Gspline2::full_a_pars1(). Unimplemented _order.", 1);
}
}
//
// ***** GIBBSmeanRandom *****
//
// Update all means of random effects using a Gibbs move
//
void
BetaGammaExtend::GIBBSmeanRandom(const RandomEff* b_obj, const CovMatrix* Dcm)
{
if (!_ngamma) return;
static int i, j, ii, jj, cl, rank;
/** Inverse variance of full conditional distribution (Psi^{-1} + N*D^{-1}) (store it in _covgamma) AND **/
/** mean of the full conditional distribution, part 1 (Psi^{-1}*nu) **/
for (j = 0; j < _ngamma; j++){
/* Diagonal */
jj = _indbA[_indgamma[j]];
if (jj < 0 || jj >= b_obj->nRandom()) throw returnR("BetaGammaExtend::GIBBSmeanRandom: Programming error, contact the author", 99);
_covgamma[_diagIgamma[j]] = _priorInvVar[_indgamma[j]] + b_obj->nCluster() * (Dcm->icovm(Dcm->diagI(jj)));
/* Off-diagonal in the jth column*/
for (i = j + 1; i < _ngamma; i++){
ii = _indbA[_indgamma[i]];
if (ii > jj) _covgamma[_diagIgamma[j] + i - j] = b_obj->nCluster() * (Dcm->icovm(Dcm->diagI(jj) + ii - jj));
else _covgamma[_diagIgamma[j] + i - j] = b_obj->nCluster() * (Dcm->icovm(Dcm->diagI(ii) + jj - ii));
}
/* Part 1 of the mean */
_meangammaTemp[j] = _priorInvVar[_indgamma[j]] * _priorMean[_indgamma[j]];
}
/** Cholesky decomposition of the inverse variance of full conditional distrib. **/
cholesky(_covgamma, &rank, &_ngamma, _diagIgamma, &_toler_chol_BetaGamma);
/** Variance of the full conditional distribution **/
/** and the inverse of the Cholesky decomposition of the inverse variance **/
chinv2(_covgamma, _ichicovgamma, &_ngamma, _diagIgamma);
/** Mean of the full conditional distribution, part 2 (+ V_M*\sum b_M - W*\sum(gamma_{-M} - b_{-M})) **/
const double* bb;
/* a) \sum b_M (store it in _sumbM) */
for (j = 0; j < _ngamma; j++) _sumbM[j] = 0.0;
bb = b_obj->bMP();
for (cl = 0; cl < b_obj->nCluster(); cl++){
for (j = 0; j < _ngamma; j++) _sumbM[j] += bb[_indbA[_indgamma[j]]];
bb += b_obj->nRandom();
}
/* b) += V_M * \sum b_M (store it first in _meangamma) */
Mxa2(_meangamma, _sumbM, Dcm->icovmP(), _indRandomUpdate, &_ngamma, &_nRandom, Dcm->diagIP());
for (j = 0; j < _ngamma; j++) _meangammaTemp[j] += _meangamma[j];
/* c) \sum (gamma_{-M} - b_{-M}) (store it in _sumgammab) */
/* d) -= W * \sum(gamma_{-M} - b_{-M}) (store it first in _meangamma) */
jj = _nRandom - _ngamma;
if (jj > 0){
if (jj != 1) throw returnR("Programming error in BetaGammaExtend::GIBBSmeanRandom, contact the author", 1);
_sumgammab[0] = 0.0;
bb = b_obj->bMP();
for (cl = 0; cl < b_obj->nCluster(); cl++){
_sumgammab[0] += (_Eb0_ - bb[0]);
bb += b_obj->nRandom();
}
Wxa(_meangamma, _sumgammab, Dcm->icovmP(), _indRandomUpdate, _indRandomKeep, &jj, &_nRandom, &_ngamma, Dcm->diagIP());
for (j = 0; j < _ngamma; j++) _meangammaTemp[j] -= _meangamma[j];
}
/** Mean of full conditional distribution, part 3 (* var(gamma(M)|...)) **/
Mxa(_meangamma, _meangammaTemp, _covgamma, &ZERO_INT, &_ngamma, &_ngamma, _diagIgamma);
/** Sample **/
rmvtnorm2(_beta, _meangamma, _ichicovgamma, &ZERO_INT, _indgamma, &_nbeta, &_ngamma, &_ngamma, &ONE_INT, _diagIgamma, &ZERO_INT);
return;
} /*** end of the function BetaGammaExtend::GIBBSmeanRandom ***/
void
writeRaggedToFile(const dd* array, const int& nR, const int& maxnC,
const int* nC, const int& multnC,
const std::string& dir, const std::string& filename, const char &flag,
const int& prec, const int& width)
{
try{
int i, j;
std::string path = dir + filename;
std::ofstream out;
openFile(out, path, flag);
/*** Write to the file ***/
std::ostringstream s;
unsigned int mlen = width;
/* Passes up to 5 rows to get things to line up nicely */
for (i = 0; i < nR && i < 5; i++) {
if (multnC * nC[i] > maxnC) throw returnR("C++ Error: multnC * nC must be <= maxnC in writeRaggedToFile", 1);
for (j = 0; j < multnC * nC[i]; j++) {
s.str("");
if (array[i*maxnC + j] >= FLT_MAX){
s << std::setw(width)
<< std::setiosflags(std::ios::fixed)
<< "1e50" << " ";
}
else{
if (array[i*maxnC + j] < 1 && array[i*maxnC + j] > -1)
s << std::scientific << std::setw(width) << std::setprecision(prec) << array[i*maxnC + j] << " ";
else
s << std::fixed << std::setw(width) << std::setprecision(prec) << array[i*maxnC + j] << " ";
}
if (s.str().length() > mlen) mlen = s.str().length();
}
}
/* Write */
// s.str("");
for (i = 0; i < nR; i++) {
if (multnC * nC[i] > maxnC) throw returnR("C++ Error: multnC * nC must be <= maxnC in writeRaggedToFile", 1);
for (j = 0; j < multnC * nC[i]; j++){
if (array[i*maxnC + j] >= FLT_MAX){
out << std::setw(mlen) << "1e50";
out << " ";
}
else{
if (array[i*maxnC + j] < 1 && array[i*maxnC + j] > -1){
out << std::scientific << std::setw(mlen) << std::setprecision(prec) << array[i*maxnC + j];
out << " ";
}
else{
out << std::fixed << std::setw(mlen) << std::setprecision(prec) << array[i*maxnC + j];
out << " ";
}
}
}
out << std::endl;
}
// out << s.str();
out.close();
return;
}
catch(returnR){
throw;
}
} /** end of function writeRaggedToFile **/
//
// PARAMETERS:
//
// Tau[M_now] ................... computed values of Tau at each iteration
// M_now ........................ current sample size used here (after taking into account 'skip' and 'by')
// dirP ......................... directory where the sample is stored
// extensP ...................... additional extension by file names (usually "_2" for doubly censored data)
// KK[2] ........................ numbers of knots on each side of the reference knot
// Phi0[(2*KK[0]+1)^2] .......... values of Phi((mu[0,i] - mu[0,j])/(sqrt(2)*sigma0)) (in COLUMN major order)
// Phi1[(2*KK[1]+1)^2] .......... values of Phi((mu[1,i] - mu[1,j])/(sqrt(2)*sigma0)) (in COLUMN major order)
// M ............................ McMC sample size (total, 'skip' and 'by' iterations included)
// * M should be <= number of rows in *.sim files
// * here: it is an index of the last iteration used to compute the average
// skip ......................... how many rows are to be skipped at the beginning of the sample
// by ........................... only every 'by' G-spline will be taken into account
// nwrite ....................... frequency of informing the user about the progress
// errP ......................... error flag
//
void
sampledKendallTau(double* Tau, int* M_now,
char** dirP, char** extensP,
const int* KK,
const double* Phi0, const double* Phi1,
const int* M, const int* skip, const int* by, const int* nwrite,
int* errP)
{
try{
double* pTau = Tau;
const int dim = 2;
const int length0 = 2*KK[0] + 1;
const int length1 = 2*KK[1] + 1;
const int total_length = length0 * length1;
// bool test = false;
int i, j, k, l, pp;
*errP = 0;
string dir = *dirP;
string extens = *extensP;
/* Open files with simulated G-splines and skip rows at the beginning of each file that are to be skipped */
int k_effect;
double* w = (double*) calloc(total_length, sizeof(double));
int** ind_mu = (int**) calloc(dim, sizeof(int*));
if (!w || !ind_mu)
throw returnR("Not enough memory available in sampledKendallTau (w/ind_mu)", 1);
for (j = 0; j < dim; j++){
ind_mu[j] = (int*) calloc(total_length, sizeof(int));
if (!ind_mu[j]) throw returnR("Not enough memory available in sampledKendallTau (ind_mu[j])", 1);
}
std::string kpath = dir + "/mixmoment" + extens + ".sim";
std::string wpath = dir + "/mweight" + extens + ".sim";
std::string mupath = dir + "/mmean" + extens + ".sim";
std::ifstream kfile, wfile, mufile;
openGsplineFiles_forTau(kfile, wfile, mufile, kpath, wpath, mupath, *skip + 1); /* skip also header */
/* Rearange Phis to have them as matrices */
double** mPhi0 = (double**) calloc(length0, sizeof(double*));
double** mPhi1 = (double**) calloc(length1, sizeof(double*));
if (!mPhi0 || !mPhi1) throw returnR("Not enough memory available in sampledKendallTau (mPhi0/mPhi1)", 1);
for (i = 0; i < length0; i++){
mPhi0[i] = (double*) calloc(length0, sizeof(double));
if (!mPhi0[i]) throw returnR("Not enough memory available in sampledKendallTau (mPhi0[i])", 1);
}
for (j = 0; j < length1; j++){
mPhi1[j] = (double*) calloc(length1, sizeof(double));
if (!mPhi1[j]) throw returnR("Not enough memory available in sampledKendallTau (mPhi1[j])", 1);
}
pp = 0;
for (k = 0; k < length0; k++){
for (i = 0; i < length0; i++){
mPhi0[i][k] = Phi0[pp];
pp++;
}
}
pp = 0;
for (l = 0; l < length1; l++){
for (j = 0; j < length1; j++){
mPhi1[j][l] = Phi1[pp];
pp++;
}
}
/* Compute Phi((mu[0,i] - mu[0,k])/(sqrt(2)*sigma0)) * Phi((mu[1,j] - mu[1,l])/(sqrt(2)*sigma1)) */
double**** PhiPhi = (double****) calloc(length0, sizeof(double***));
if (!PhiPhi) throw returnR("Not enough memory available in sampledKendallTau (PhiPhi)", 1);
for (i = 0; i < length0; i++){
PhiPhi[i] = (double***) calloc(length1, sizeof(double**));
if (!PhiPhi[i]) throw returnR("Not enough memory available in sampledKendallTau (PhiPhi[i])", 1);
for (j = 0; j < length1; j++){
PhiPhi[i][j] = (double**) calloc(length0, sizeof(double*));
if (!PhiPhi[i][j]) throw returnR("Not enough memory available in sampledKendallTau (PhiPhi[i][j])", 1);
for (k = 0; k < length0; k++){
PhiPhi[i][j][k] = (double*) calloc(length1, sizeof(double));
if (!PhiPhi[i][j][k]) throw returnR("Not enough memory available in sampledKendallTau (PhiPhi[i][j][k])", 1);
for (l = 0; l < length1; l++){
PhiPhi[i][j][k][l] = mPhi0[i][k] * mPhi1[j][l];
}
}
}
}
/* Loop over McMC iterations */
if (*skip >= *M) throw returnR("More McMC iterations should be skipped than available", 1);
readGsplineFromFiles_forTau(&k_effect, w, ind_mu, 0, *skip, dim, KK, total_length, kfile, wfile, mufile, kpath, wpath, mupath);
evalKendallTau(pTau, &dim, &k_effect, w, ind_mu, PhiPhi);
*M_now = 1;
int by_1 = *by - 1;
int backs = 0;
Rprintf("Iteration ");
for (int iter = *skip + 1 + (*by); iter <= *M; iter += (*by)){
pTau++;
readGsplineFromFiles_forTau(&k_effect, w, ind_mu, by_1, iter, dim, KK, total_length, kfile, wfile, mufile, kpath, wpath, mupath);
evalKendallTau(pTau, &dim, &k_effect, w, ind_mu, PhiPhi);
(*M_now)++;
if (!(iter % (*nwrite)) || iter == *M){
for (i = 0; i < backs; i++) Rprintf("\b");
Rprintf("%d", iter);
backs = int(log10(double(iter))) + 1;
}
} /** end of the while over iterations **/
Rprintf("\n");
/* Close files with simulated G-splines */
kfile.close();
wfile.close();
mufile.close();
/* Cleaning */
for (i = 0; i < length0; i++){
for (j = 0; j < length1; j++){
for (k = 0; k < length0; k++){
free(PhiPhi[i][j][k]);
}
free(PhiPhi[i][j]);
}
free(PhiPhi[i]);
}
free(PhiPhi);
for (j = 0; j < dim; j++){
free(ind_mu[j]);
}
free(ind_mu);
free(w);
return;
}
catch(returnR rr){
*errP = rr.errflag();
return;
}
} /** end of function 'sampledKendallTau' **/
void
readFromFile(dd* array, int* nread,
const int& nR, const int& nC, const int& header,
const int& skip, const int& by,
const std::string& dir, const std::string& filename,
const int& skipOnRow)
{
try{
int i, j, ii;
int size = nR * nC;
if (size <= 0) throw returnR("C++ Error: File of null size is to be read.", 99);
if (skip < 0) throw returnR("C++ Error: 'skip' parameter must be >= 0 in 'readFromFile'", 1);
if (by <= 0) throw returnR("C++ Error: 'by' parameter must be > 0 in 'readFromFile'", 1);
if (skip >= nR) throw returnR("C++ Error: too many rows are to be skipped by 'readFromFile'", 1);
std::string path = dir + filename;
std::string errmes, mess;
char cmess[200];
std::ifstream file(path.c_str(), std::ios::in);
dd temp;
if (!file){
errmes = std::string("C++ Error: Could not open ") + path;
throw returnR(errmes, 99);
}
else{
mess = std::string("Reading ") + path + "\n";
strcpy(cmess, mess.c_str());
Rprintf(cmess);
/*** Skip what is to be skipped (header included) ***/
char ch;
for (i = 0; i < skip + header; i++){
file.get(ch);
while (ch != '\n') file.get(ch);
}
/*** Read the first row to be read ***/
*nread = 1;
double* veld = array;
if (file.eof()){
errmes = std::string("C++ Error: Reached end of file ") + path + std::string(" before ")
+ char(*nread) + std::string(" rows were read.");
throw returnR(errmes, 99);
}
for (j = 0; j < skipOnRow; j++){
if (file.eof()){
errmes = std::string("C++ Error: Reached end of file ") + path + std::string(" before ")
+ char(*nread) + std::string(" rows were read.");
throw returnR(errmes, 99);
}
file >> temp;
}
for (j = skipOnRow; j < nC + skipOnRow; j++){
if (file.eof()){
errmes = std::string("C++ Error: Reached end of file ") + path + " before "
+ char(*nread) + std::string(" rows were read.");
throw returnR(errmes, 99);
}
file >> (*veld);
veld++;
}
/*** Read remaining rows to be read ***/
for (i = skip + 1 + by; i <= nR; i += by){
/** Skip by-1 rows **/
for (ii = 0; ii < by - 1; ii++){
file.get(ch);
while (ch != '\n') file.get(ch);
}
/** Read the values **/
(*nread)++;
for (j = 0; j < skipOnRow; j++){
if (file.eof()){
errmes = std::string("C++ Error: Reached end of file ") + path + std::string(" before ")
+ char(*nread) + std::string(" rows were read.");
throw returnR(errmes, 99);
}
file >> temp;
}
for (j = skipOnRow; j < nC + skipOnRow; j++){
if (file.eof()){
errmes = std::string("C++ Error: Reached end of file ") + path + " before "
+ char(*nread) + std::string(" rows were read.");
throw returnR(errmes, 99);
}
file >> (*veld);
veld++;
}
file.get(ch);
while (ch != '\n') file.get(ch);
}
}
file.close();
return;
} // end of try
catch(returnR){
throw;
}
} // end of the function readFromFile
//
// regResOnset[nP]: regression residuals for onset
// regResTime[nP]: regression residuals for time-to-event
//
// nP[1]: total number of observations (over all clusters)
//
// gg_zeta: G-spline giving the distribution of the error in the onset part
// mu_zeta[gg_zeta->dim(), gg_zeta->length(j)]: already computed knots of the onset error G-spline
// rM_zeta[nP]: allocation labels for the onset error
// \in {0, ..., gg_zeta->total_length() - 1}
//
// gg_eps: G-spline giving the distribution of the error in the time-to-event part
// mu_eps[gg_eps->dim(), gg_eps->length(j)]: already computed knots of the time-to-event error G-spline
// rM_eps[nP]: allocation labels for the time-to-event error
// \in {0, ..., gg_eps->total_length() - 1}
//
void
update(RandomEff32::RE *data,
double *regResOnset, double *regResTime,
const int *nP,
const Gspline *gg_zeta, double** const mu_zeta, const int *rM_zeta,
const Gspline *gg_eps, double** const mu_eps, const int *rM_eps)
{
static int info[1];
static int cl, i;
static double invsigscale2_zeta, invsigscale2_eps;
static double *sumd2, *sumb2, *sumdb;
static double *tempP, *temp2P;
static double *regResOnsetP, *regResTimeP;
static double *propMean_d, *propMean_b;
static double *dP, *bP;
static const double *cdP;
static const int *rzetaP, *repsP, *nwithinClP;
/***** UPDATE OF RANDOM EFFECTS *****/
/***** ======================== *****/
/*** Compute invsigscale2's ***/
invsigscale2_zeta = gg_zeta->invscale2(0) * gg_zeta->invsigma2(0);
invsigscale2_eps = gg_eps->invscale2(0) * gg_eps->invsigma2(0);
/*** Loop over clusters ***/
/*** Within the loop compute also sumd2, sumb2, sumbd needed for the update of D afterwards ***/
regResOnsetP = regResOnset;
regResTimeP = regResTime;
dP = data->_d;
bP = data->_b;
rzetaP = rM_zeta;
repsP = rM_eps;
nwithinClP = data->_nwithinCl;
sumd2 = data->_propSi;
sumdb = sumd2 + 1;
sumb2 = sumdb + 1;
*sumd2 = 0;
*sumdb = 0;
*sumb2 = 0;
propMean_d = data->_propMean;
propMean_b = propMean_d + 1;
for (cl = 0; cl < data->_nCluster; cl++){
/*** Compute the inverse variance of the full conditional distribution, see page 57 of red notes ***/
tempP = data->_propVar;
temp2P = data->_Di;
*tempP = *temp2P + (*nwithinClP) * invsigscale2_zeta; /* _propVar[0,0] */
tempP++;
temp2P++;
*tempP = *temp2P; /* _propVar[1,0] */
tempP++;
temp2P++;
*tempP = *temp2P + (*nwithinClP) * invsigscale2_eps; /* _propVar[1,1] */
/*** Compute canonical mean of the full conditional distribution, see p. 57 of the red notes ***/
/*** Part comming from the likelihood ***/
*propMean_d = 0.0;
*propMean_b = 0.0;
for (i = 0; i < *nwithinClP; i++){ /** loop over the observations in a given cluster **/
/* Add old value of the random intercept to regRes */
/* Compute sum(y - alpha - x'beta - scale*mu), store it in _propMean */
*regResOnsetP += (*dP);
*propMean_d += (*regResOnsetP) - (gg_zeta->intcpt(0) + gg_zeta->scale(0)*mu_zeta[0][*rzetaP]);
regResOnsetP++;
rzetaP++;
*regResTimeP += (*bP);
*propMean_b += (*regResTimeP) - (gg_eps->intcpt(0) + gg_eps->scale(0)*mu_eps[0][*repsP]);
regResTimeP++;
repsP++;
} /** end of the loop over observations in a given cluster **/
*propMean_d *= invsigscale2_zeta;
*propMean_b *= invsigscale2_eps;
/** Sample new value of the random intercepts (d, b) in given cluster **/
AK_BLAS_LAPACK::chol_dpptrf(data->_propVar, &data->_nRandom, info);
if (*info) throw returnR("Trap in structRandomEff32.cpp: update. Singular covariance matrix of the full conditional distribution of the random effects", 1);
Mvtdist3::rmvnormC2006(data->_propValue, data->_propMean, data->_propVar, &data->_nRandom);
*dP = data->_propValue[0];
*bP = data->_propValue[1];
/** Update sumd2, sumb2, sumdb **/
*sumd2 += (*dP)*(*dP);
*sumb2 += (*bP)*(*bP);
*sumdb += (*dP)*(*bP);
/** Update regResOnset and regResTime **/
regResOnsetP -= *nwithinClP;
for (i = 0; i < *nwithinClP; i++){
*regResOnsetP -= (*dP);
regResOnsetP++;
}
dP++;
regResTimeP -= *nwithinClP;
for (i = 0; i < *nwithinClP; i++){
*regResTimeP -= (*bP);
regResTimeP++;
}
bP++;
nwithinClP++;
}
/***** UPDATE OF THE COVARIANCE MATRIX OF RANDOM EFFECTS *****/
/***** ================================================= *****/
/*** Inverse scale matrix of the Wishart full conditional ***/
tempP = data->_propSi;
temp2P = data->_priorSi;
*tempP = *temp2P + (*sumd2); /* _propSi[0,0] */
tempP++;
temp2P++;
*tempP = *temp2P + (*sumdb); /* _propSi[1,0] */
tempP++;
temp2P++;
*tempP = *temp2P + (*sumb2); /* _propSi[1,1] */
/*** Sample from the Wishart distribution ***/
Mvtdist3::rwishart3(data->_Di, data->_workWishart, &data->_propDF, data->_propSi, &data->_nRandom, 1);
/*** Inverse covariance matrix -> covariance matrix and its determinant ***/
cdP = data->_Di;
dP = data->_D;
for (i = 0; i < data->_lD; i++){
*dP = *cdP;
dP++;
cdP++;
}
AK_BLAS_LAPACK::chol_dpptrf(data->_D, &data->_nRandom, info);
if (*info){
throw returnR("Error in structRandomEff32.cpp: update. Sampled covariance matrix is not positive definite.", 1);
}
data->_detD = 1/(data->_D[0] * data->_D[0] * data->_D[2] * data->_D[2]);
AK_BLAS_LAPACK::chol_dpptri(data->_D, &data->_nRandom, info);
return;
}
// gridA[sum(ngrid)] ............ grids to compute predictive quantities for each observation
// loggridA[sum(ngrid)] ......... logarithm of the grid
// ngrid[nobs] .................. lengths of grids for each observation
// onlyAver ..................... 0/1: compute only predictive quantities or return values as well?
// predictP[4] .................. 0/1 indicating which predictive quantities are to be computed
// predictP[0] ... densities?
// predictP[1] ... survivor functions?
// predictP[2] ... hazards?
// predictP[3] ... cumulative hazards?
// M ............................ McMC sample size (total, 'skip' and 'by' iterations included)
// * M should be <= number of rows in *.sim files
// * here: it is an index of the last iteration used to compute the average
// skip ......................... how many rows are to be skipped at the beginning of the sample
// by ........................... only every 'by' G-spline will be taken into account
// nwrite ....................... frequency of informing the user about the progress
// version ...................... arbitrary or 32
// if = 32, then model for doubly-interval censored data is assumed with G-spline errors
// and bivariate normal random intercepts in the onset and time-to-event parts of the model
// Onset ........................ only used by version = 32
// equal to 1 if we are predicting the onset
// equak to 0 if we are predicting the event
// errP ......................... error flag (0 on output if everything OK)
//
void
predictive_GS(double *averDens, double *averS, double *averHaz, double *averCumHaz,
double *valDens, double *valS, double *valHaz, double *valCumHaz,
double *quantDens, double *quantS, double *quantHaz, double *quantCumHaz,
const int *dimsP, const double *X, const int *obsdims,
int *M_now, char **dirP, char **extensP, char **extens_adjP,
const int *GsplI,
const int *objBetaI, const double *objBetaD,
const int *objbI, const double *objbD,
const int *b_GsplI,
const double *gridA, const double *loggridA, const int *ngrid,
double *probsA, const int *nquant, int *onlyAver, const int *predictP,
const int *M, const int *skip, const int *by, const int *nwrite,
const int *version, const int *Onset, int *errP)
{
try{
GetRNGstate();
double dtemp;
int itemp;
int i, j, ix;
double tmpd;
*errP = 0;
string dir = *dirP;
string extens = *extensP;
string extens_adj = *extens_adjP;
/*** Dimensionality parameters ***/
const int *nobs = dimsP;
const int *ncluster = dimsP + 1;
const int *nwithin = dimsP + 2;
const int M_now_max = *M_now;
/*** What to predict? ***/
const int *predDens = predictP + 0;
const int *predS = predictP + 1;
const int *predHaz = predictP + 2;
const int *predCumHaz = predictP + 3;
/*** Quantiles ***/
if (*nquant <= 0) *onlyAver = 1;
/*** Needed G-spline parameters ***/
const int *dim = GsplI + 0;
const int *total_length = GsplI + 1;
const int *GsplK = GsplI + 2; /* K1 (and K2) */
int *Glength = (int*) calloc(*dim, sizeof(int));
if (!Glength) throw returnR("Not enough memory available in predictive_GS (Glength)", 1);
for (j = 0; j < *dim; j++) Glength[j] = 2*GsplK[j] + 1;
/*** Check obsdims ***/
for (i = 0; i < *nobs; i++){
if (obsdims[i] < 0 || obsdims[i] >= *dim) throw returnR("Error: Inconsistent 'obsdims' parameter supplied to predictive_GS", 1);
}
/*** Check grid and log-grid ***/
int sum_ngrid = 0;
for (i = 0; i < *nobs; i++) sum_ngrid += ngrid[i];
/*** Object for regression parameters ***/
BetaGamma* beta = new BetaGamma;
if (!beta) throw returnR("Not enough memory available in predictive_GS (beta)", 1);
*beta = BetaGamma(objBetaI, objBetaD);
/*** Object for random effects ***/
RandomEff *bb = new RandomEff;
RandomEff32::RE *db = new RandomEff32::RE;
bool reff_NORMAL = true; /** BUT NOT version = 32 !**/
/*** Objects for bivariate normal random effects in version = 32 ***/
double *dval, *bval, *dbval;
double D32[7] = {1, 0, 1, 2, 1, 0, 1}; /** parD argument for RandomEff32::RE initializer (filled arbitrary) **/
if (*version == 32){
reff_NORMAL = false;
dval = (double*) calloc(objbI[2], sizeof(double)); // objbI[2] = nCluster
bval = (double*) calloc(objbI[2], sizeof(double)); // objbI[2] = nCluster
RandomEff32::init(db, dval, bval, D32, objbI, objbI);
if (*Onset) dbval = dval;
else dbval = bval;
}
else{
dval = NULL;
bval = NULL;
dbval = NULL;
if (beta->nRandom()){
*bb = RandomEff(objbI, objbD);
if (bb->type_prior() == Gspline_) reff_NORMAL = false;
}
}
/*** Object for covariance matrix of random effects ***/
/*** or arrays for G-spline parameters definig distribution of random effects ***/
CovMatrix *DD = new CovMatrix;
const int nD = (beta->nRandom() * (beta->nRandom() + 1)) / 2;
const int *dim_b = b_GsplI + 0;
const int *total_length_b = b_GsplI + 1;
int k_effect_b;
int *rM_b = &itemp;
double *cum_w_b = &dtemp;
double *sig_scale_b = &dtemp;
double *prop_mu_b = &dtemp;
if (*version != 32){
if (beta->nRandom()){
if (reff_NORMAL){
int DDparmI[2];
DDparmI[0] = beta->nRandom();
DDparmI[1] = InvWishart; /** it does not matter what is filled here **/
double *DDparmD = (double*) calloc(2*nD + 1, sizeof(double));
if (!DDparmD) throw returnR("Not enough memory available in predictive_GS (DDparmD)", 1);
for (j = 0; j < beta->nRandom(); j++){ /** initial cov matrix and scale matrix equal to identity **/
ix = (j * (2*beta->nRandom() - j + 1))/2; /** again, it does not matter what is filled here **/
DDparmD[ix] = DDparmD[nD + 1 + ix] = 1.0; /** initial matrix must only be positive definite **/
for (i = j+1; i < beta->nRandom(); i++){ /** to pass the CovMatrix constructor **/
DDparmD[ix + i - j] = DDparmD[nD + 1 + ix + i - j] = 0.0;
}
}
DDparmD[nD] = beta->nRandom() + 2; /** 'prior degrees of freedom', it does not matter what **/
*DD = CovMatrix(DDparmI, DDparmD);
free(DDparmD);
}
else{ /** G-spline random effects **/
cum_w_b = (double*) calloc(*total_length_b, sizeof(double));
prop_mu_b = (double*) calloc(*total_length_b, sizeof(double));
sig_scale_b = (double*) calloc(*dim_b, sizeof(double));
rM_b = (int*) calloc(*ncluster, sizeof(int));
if (!cum_w_b || !prop_mu_b || !sig_scale_b) throw returnR("Not enough memory available in predictive_GS (cum_w_b/sig_scale_b)", 1);
if (!rM_b) throw returnR("Not enough memory available in predictive_GS (rM_b)", 1);
}
}
} /** end of if (*version != 32) **/
/*** Space for linear predictors ***/
double *linPred = (double*) calloc(*nobs, sizeof(double));
if (!linPred) throw returnR("Not enough memory available in predictive_GS (linPred)", 1);
for (i = 0; i < *nobs; i++) linPred[i] = 0.0;
/*** Allocate memory for needed quantities from simulated G-splines ***/
int k_effect;
double *sigma = (double*) calloc(*dim, sizeof(double));
double *gamma = (double*) calloc(*dim, sizeof(double));
double *delta = (double*) calloc(*dim, sizeof(double));
double *intcpt = (double*) calloc(*dim, sizeof(double));
double *scale = (double*) calloc(*dim, sizeof(double));
double *delta_sig = (double*) calloc(*dim, sizeof(double));
double *inv_sig_scale = (double*) calloc(*dim, sizeof(double));
if (!sigma || !gamma || !delta || !inv_sig_scale || !intcpt || !scale || !delta_sig)
throw returnR("Not enough memory available in predictive_GS (sigma/gamma/delta/intcpt/scale/delta_sig/inv_sig_scale)", 1);
double **w_marg = (double**) calloc(*dim, sizeof(double*));
double **mu_sig_marg = (double**) calloc(*dim, sizeof(double*));
if (!w_marg || !mu_sig_marg)
throw returnR("Not enough memory available in predictive_GS (w_marg/sc_mu_marg)", 1);
for (j = 0; j < *dim; j++){
w_marg[j] = (double*) calloc(Glength[j], sizeof(double));
mu_sig_marg[j] = (double*) calloc(Glength[j], sizeof(double));
if (!w_marg[j] || !mu_sig_marg[j]) throw returnR("Not enough memory available in predictive_GS (w_marg[j]/mu_sig_marg[j])", 1);
}
/*** Open files with simulated G-splines ***/
std::string kpath = dir + "/mixmoment" + extens + ".sim";
std::string wpath = dir + "/mweight" + extens + ".sim";
std::string mupath = dir + "/mmean" + extens + ".sim";
std::string sigmapath = dir + "/gspline" + extens + ".sim";
std::ifstream kfile, wfile, mufile, sigmafile;
openGsplineFiles(kfile, wfile, mufile, sigmafile, kpath, wpath, mupath, sigmapath, *skip + 1); /* skip also header */
/*** Open files with simulated remaining quantities ***/
std::string betapath = dir + "/beta" + extens + ".sim";
std::ifstream betafile;
std::string Dpath = dir + "/D" + extens + ".sim";
std::ifstream Dfile;
std::string D32path = dir + "/D" + ".sim";
std::ifstream D32file;
std::string kpath_b = dir + "/mixmoment" + extens_adj + ".sim";
std::string wpath_b = dir + "/mweight" + extens_adj + ".sim";
std::string mupath_b = dir + "/mmean" + extens_adj + ".sim";
std::string sigmapath_b = dir + "/gspline" + extens_adj + ".sim";
std::ifstream kfile_b, wfile_b, mufile_b, sigmafile_b;
openRegresFiles(betafile, Dfile, betapath, Dpath, *skip + 1, beta->nbeta(), beta->nRandom(), reff_NORMAL); /* skip also header */
if (*version == 32){
openD32File(D32file, D32path, *skip + 1); /* skip also header */
}
else{
if (beta->nRandom() && !reff_NORMAL){
openGsplineFiles(kfile_b, wfile_b, mufile_b, sigmafile_b, kpath_b, wpath_b, mupath_b, sigmapath_b, *skip + 1);
}
}
/*** Reset averages ***/
resetAverage(averDens, nobs, ngrid, predDens);
resetAverage(averS, nobs, ngrid, predS);
resetAverage(averHaz, nobs, ngrid, predHaz);
resetAverage(averCumHaz, nobs, ngrid, predCumHaz);
/*** Loop over McMC iterations ***/
double *vvDens = valDens;
double *vvS = valS;
double *vvHaz = valHaz;
double *vvCumHaz = valCumHaz;
const int *shift_pointer_inEval = (*onlyAver ? &ONE_INT : &M_now_max);
if (*skip >= *M) throw returnR("More McMC iterations should be skipped than available", 1);
readGsplineFromFiles2(&k_effect, w_marg, mu_sig_marg, gamma, sigma, delta, intcpt, scale, delta_sig, 0, *skip,
*dim, *total_length, GsplK,
kfile, wfile, mufile, sigmafile, kpath, wpath, mupath, sigmapath);
readRegresFromFiles(beta, DD, 0, *skip, betafile, Dfile, betapath, Dpath, reff_NORMAL);
if (*version == 32){
readDfromFile(db, 0, *skip, D32file, D32path);
predict_db(db);
linPred_GS(linPred, beta, dbval, X, nwithin, nobs, ncluster);
}
else{
if (beta->nRandom()){
if (reff_NORMAL){
bb->predictNormalRE(beta, DD);
}
else{
readGsplineFromFiles3(&k_effect_b, cum_w_b, prop_mu_b, sig_scale_b, 0, *skip, *dim_b, *total_length_b,
kfile_b, wfile_b, mufile_b, sigmafile_b, kpath_b, wpath_b, mupath_b, sigmapath_b);
bb->predictGspl_intcpt(&k_effect_b, cum_w_b, prop_mu_b, sig_scale_b, rM_b);
}
}
linPred_GS(linPred, beta, bb->bMP(), X, nwithin, nobs, ncluster);
}
evalPredFuns(averDens, averS, averHaz, averCumHaz, vvDens, vvS, vvHaz, vvCumHaz, obsdims, nobs, ngrid, gridA, loggridA,
linPred, dim, Glength, w_marg, mu_sig_marg, intcpt, sigma, scale, inv_sig_scale, predictP, &_zero_weight,
shift_pointer_inEval);
*M_now = 1;
int by_1 = *by - 1;
int jump_value = (*onlyAver ? 0 : 1);
int backs = 0;
Rprintf("Iteration ");
for (int iter = *skip + 1 + (*by); iter <= *M; iter += (*by)){
if (*M_now >= M_now_max) throw returnR("Error: Higher sample size would be used than indicated", 1);
if (*predDens) vvDens += jump_value;
if (*predS) vvS += jump_value;
if (*predHaz) vvHaz += jump_value;
if (*predCumHaz) vvCumHaz += jump_value;
readGsplineFromFiles2(&k_effect, w_marg, mu_sig_marg, gamma, sigma, delta, intcpt, scale, delta_sig, by_1, iter,
*dim, *total_length, GsplK,
kfile, wfile, mufile, sigmafile, kpath, wpath, mupath, sigmapath);
readRegresFromFiles(beta, DD, by_1, iter, betafile, Dfile, betapath, Dpath, reff_NORMAL);
if (*version == 32){
readDfromFile(db, by_1, iter, D32file, D32path);
predict_db(db);
linPred_GS(linPred, beta, dbval, X, nwithin, nobs, ncluster);
}
else{
if (beta->nRandom()){
if (reff_NORMAL){
bb->predictNormalRE(beta, DD);
}
else{
readGsplineFromFiles3(&k_effect_b, cum_w_b, prop_mu_b, sig_scale_b, by_1, iter, *dim_b, *total_length_b,
kfile_b, wfile_b, mufile_b, sigmafile_b, kpath_b, wpath_b, mupath_b, sigmapath_b);
bb->predictGspl_intcpt(&k_effect_b, cum_w_b, prop_mu_b, sig_scale_b, rM_b);
}
}
linPred_GS(linPred, beta, bb->bMP(), X, nwithin, nobs, ncluster);
}
evalPredFuns(averDens, averS, averHaz, averCumHaz,
vvDens, vvS, vvHaz, vvCumHaz,
obsdims, nobs, ngrid, gridA, loggridA,
linPred, dim, Glength, w_marg, mu_sig_marg, intcpt, sigma, scale, inv_sig_scale, predictP, &_zero_weight,
shift_pointer_inEval);
(*M_now)++;
if (!(iter % (*nwrite)) || iter == *M){
for (i = 0; i < backs; i++) Rprintf("\b");
Rprintf("%d", iter);
backs = int(log10(double(iter))) + 1;
}
} /** end of the while over iterations **/
Rprintf("\n");
/*** Close files with simulated G-splines and regression quantities ***/
closeGsplineFiles(kfile, wfile, mufile, sigmafile);
closeRegresFiles(betafile, Dfile, beta->nbeta(), beta->nRandom(), reff_NORMAL);
if (*version == 32){
D32file.close();
}
else{
if (beta->nRandom() && !reff_NORMAL) closeGsplineFiles(kfile_b, wfile_b, mufile_b, sigmafile_b);
}
/*** McMC averages ***/
cumsum2average(averDens, M_now, nobs, ngrid, predDens);
cumsum2average(averS, M_now, nobs, ngrid, predS);
cumsum2average(averHaz, M_now, nobs, ngrid, predHaz);
cumsum2average(averCumHaz, M_now, nobs, ngrid, predCumHaz);
/*** Indeces of quantile values in sampled chain (indexing starting from 0) ***/
// indquant1, indquant2 ..... quantile = q*sample[indquant1] + (1-q)sample[indquant2]
//
int *indquant1 = &itemp;
int *indquant2 = &itemp;
if (!(*onlyAver)){
indquant1 = (int*) calloc(*nquant, sizeof(int));
indquant2 = (int*) calloc(*nquant, sizeof(int));
if (!indquant1 || !indquant2) throw returnR("Error Not enough memory available in predictive_GS (indquant1/indquant2)", 1);
for (i = 0; i < *nquant; i++){
if (probsA[i] < 0 || probsA[i] > 1) throw returnR("Error: Incorrect probs values supplied.", 1);
if (probsA[i] <= 0) indquant1[i] = indquant2[i] = 0;
else{
if (probsA[i] >= 1) indquant1[i] = indquant2[i] = *M_now - 1;
else{
tmpd = probsA[i] * double(*M_now);
if (fabs(tmpd - floor(tmpd + 1e-8)) < 1e-8){
indquant1[i] = int(floor(tmpd)) - 1;
indquant2[i] = int(floor(tmpd));
}
else{
indquant1[i] = indquant2[i] = int(floor(tmpd));
}
}
}
}
Rprintf("\nComputing quantiles.");
value2quantile(valDens, quantDens, probsA, indquant1, indquant2, nquant, M_now, nobs, ngrid, predDens, shift_pointer_inEval);
value2quantile(valS, quantS, probsA, indquant1, indquant2, nquant, M_now, nobs, ngrid, predS, shift_pointer_inEval);
value2quantile(valHaz, quantHaz, probsA, indquant1, indquant2, nquant, M_now, nobs, ngrid, predHaz, shift_pointer_inEval);
value2quantile(valCumHaz, quantCumHaz, probsA, indquant1, indquant2, nquant, M_now, nobs, ngrid, predCumHaz, shift_pointer_inEval);
}
PutRNGstate();
/*** Cleaning ***/
if (!(*onlyAver)){
free(indquant1);
free(indquant2);
}
for (j = 0; j < *dim; j++){
free(w_marg[j]);
free(mu_sig_marg[j]);
}
free(w_marg);
free(mu_sig_marg);
free(sigma);
free(gamma);
free(delta);
free(inv_sig_scale);
free(intcpt);
free(scale);
free(delta_sig);
free(Glength);
free(linPred);
delete DD;
if (*version == 32){
free(bval);
free(dval);
}
else{
if (beta->nRandom()){
if (reff_NORMAL){
// delete DD;
}
else{
free(sig_scale_b);
free(prop_mu_b);
free(cum_w_b);
free(rM_b);
}
}
}
delete db;
delete bb;
delete beta;
return;
}
catch(returnR rr){
*errP = rr.errflag();
PutRNGstate();
return;
}
}
//
// aa: Pointer to _a that is updated
// expaa: Pointer to _expa corresponding to _a that is updated
// Abscis[mcmc_Gspline2::_nabscis]: Starting abscisae for ARS or working space for the slice sampler
// ia: Index of the a that is updated (on the scale -K,...,K)
// a_ipars[2]: a_ipars[0] = number of all observations
// a_ipars[1] = number of observations currently belonging to the component of the a
// overrelax: 1/0 indicating whether overrelaxation is to be used (used only when the slice sampler is used,
// ignored otherwise)
//
void
Gspline2::update_a1(double *aa, double *expaa, double *Abscis,
const int *ia, const int *a_ipars, const int *overrelax)
{
static double a_pars[4];
static double newa;
static double *sumexpa, *hx, *hpx, *abscis;
static int i;
static int _ONE_INT = 1;
sumexpa = _sumexpa.a();
this->full_a_pars1(a_pars + 0, a_pars + 1, ia, aa); /* compute mean and inv. variance of [a[ia] | a[-ia], lambda] */
a_pars[2] = *expaa;
a_pars[3] = *sumexpa;
/*** Find the mode of the full conditional (if necessary) ***/
/*** Store this mode in _abscis[ia][1] ***/
/*** Compute either starting abscissae for ARS or initial guesses for interval defining the slice ***/
switch (_type_update_a){
case mcmc_Gspline2::Slice:
case mcmc_Gspline2::ARS_mode:
mcmc_Gspline2::find_eval_abscis(Abscis, _hx.a(), _hpx.a(), ia, &_ONE_INT, aa, a_pars, a_ipars);
break;
case mcmc_Gspline2::ARS_quantile: /** Starting abscissae are taken as quantiles of an upper hull from the previous iteration **/
/** Evaluate the function to sample from in starting abscissae **/
abscis = Abscis;
hx = _hx.a();
hpx = _hpx.a();
for (i = 0; i < mcmc_Gspline2::_nabscis; i++){
mcmc_Gspline2::full_a_logdens(abscis, hx, hpx, a_pars, a_ipars);
abscis++;
hx++;
hpx++;
}
break;
default:
throw returnR("Error in Gspline2_updateWeights.cpp: Gspline2::update_a1. Unimplemented _type_update_a", 1);
}
/** Check whether starting abscissae/initial guesses for the interval defining the slice lie on correct size of the mode **/
mcmc_Gspline2::check_abscis(Abscis, _hx.a(), _hpx.a(), a_pars, a_ipars);
/** Sample new a **/
switch (_type_update_a){
case mcmc_Gspline2::Slice:
mcmc_Gspline2::sample_a_by_slice(&newa, Abscis, _hx.a(), _hpx.a(), ia, &_ONE_INT, aa, a_pars, a_ipars, overrelax);
break;
case mcmc_Gspline2::ARS_quantile:
case mcmc_Gspline2::ARS_mode:
mcmc_Gspline2::sample_a_by_ARS(&newa, Abscis, _hx.a(), _hpx.a(), _rwv.a(), _iwv.a(), ia, &_ONE_INT, aa, a_pars, a_ipars, &_type_update_a);
break;
default:
throw returnR("Error in Gspline2_updateWeights.cpp: Gspline2::update_a1. Unimplemented _type_update_a", 1);
}
/** Update exp(a) and sum(exp(a)) **/
*aa = newa;
*sumexpa -= *expaa;
if (*aa >= mcmc_Gspline2::_log_inf){
*aa = mcmc_Gspline2::_log_inf;
*expaa = mcmc_Gspline2::_exp_emax;
*sumexpa = mcmc_Gspline2::_exp_emax;
}
else{
*expaa = exp(*aa);
*sumexpa += *expaa;
}
return;
}
