SEXP coxfit6(SEXP maxiter2, SEXP time2, SEXP status2,
SEXP covar2, SEXP offset2, SEXP weights2,
SEXP strata2, SEXP method2, SEXP eps2,
SEXP toler2, SEXP ibeta, SEXP doscale2) {
int i,j,k, person;
double **covar, **cmat, **imat; /*ragged arrays */
double wtave;
double *a, *newbeta;
double *a2, **cmat2;
double *scale;
double denom=0, zbeta, risk;
double temp, temp2;
int ndead; /* actually, the sum of their weights */
double newlk=0;
double dtime, d2;
double deadwt; /*sum of case weights for the deaths*/
double efronwt; /* sum of weighted risk scores for the deaths*/
int halving; /*are we doing step halving at the moment? */
int nrisk; /* number of subjects in the current risk set */
/* copies of scalar input arguments */
int nused, nvar, maxiter;
int method;
double eps, toler;
int doscale;
/* vector inputs */
double *time, *weights, *offset;
int *status, *strata;
/* returned objects */
SEXP imat2, means2, beta2, u2, loglik2;
double *beta, *u, *loglik, *means;
SEXP sctest2, flag2, iter2;
double *sctest;
int *flag, *iter;
SEXP rlist, rlistnames;
int nprotect; /* number of protect calls I have issued */
/* get local copies of some input args */
nused = LENGTH(offset2);
nvar = ncols(covar2);
method = asInteger(method2);
maxiter = asInteger(maxiter2);
eps = asReal(eps2); /* convergence criteria */
toler = asReal(toler2); /* tolerance for cholesky */
doscale = asInteger(doscale2);
time = REAL(time2);
weights = REAL(weights2);
offset= REAL(offset2);
status = INTEGER(status2);
strata = INTEGER(strata2);
/*
** Set up the ragged arrays and scratch space
** Normally covar2 does not need to be duplicated, even though
** we are going to modify it, due to the way this routine was
** was called. In this case NAMED(covar2) will =0
*/
nprotect =0;
if (NAMED(covar2)>0) {
PROTECT(covar2 = duplicate(covar2));
nprotect++;
}
covar= dmatrix(REAL(covar2), nused, nvar);
PROTECT(imat2 = allocVector(REALSXP, nvar*nvar));
nprotect++;
imat = dmatrix(REAL(imat2), nvar, nvar);
a = (double *) R_alloc(2*nvar*nvar + 4*nvar, sizeof(double));
newbeta = a + nvar;
a2 = newbeta + nvar;
scale = a2 + nvar;
cmat = dmatrix(scale + nvar, nvar, nvar);
cmat2= dmatrix(scale + nvar +nvar*nvar, nvar, nvar);
/*
** create output variables
*/
PROTECT(beta2 = duplicate(ibeta));
beta = REAL(beta2);
PROTECT(means2 = allocVector(REALSXP, nvar));
means = REAL(means2);
PROTECT(u2 = allocVector(REALSXP, nvar));
u = REAL(u2);
PROTECT(loglik2 = allocVector(REALSXP, 2));
loglik = REAL(loglik2);
PROTECT(sctest2 = allocVector(REALSXP, 1));
sctest = REAL(sctest2);
PROTECT(flag2 = allocVector(INTSXP, 1));
flag = INTEGER(flag2);
PROTECT(iter2 = allocVector(INTSXP, 1));
iter = INTEGER(iter2);
nprotect += 7;
/*
** Subtract the mean from each covar, as this makes the regression
** much more stable.
*/
for (i=0; i<nvar; i++) {
temp=0;
for (person=0; person<nused; person++) temp += covar[i][person];
temp /= nused;
means[i] = temp;
for (person=0; person<nused; person++) covar[i][person] -=temp;
if (doscale==1) { /* and also scale it */
temp =0;
for (person=0; person<nused; person++) {
temp += fabs(covar[i][person]);
}
if (temp > 0) temp = nused/temp; /* scaling */
else temp=1.0; /* rare case of a constant covariate */
scale[i] = temp;
for (person=0; person<nused; person++) covar[i][person] *= temp;
}
}
if (doscale==1) {
for (i=0; i<nvar; i++) beta[i] /= scale[i]; /*rescale initial betas */
}
else {
for (i=0; i<nvar; i++) scale[i] = 1.0;
}
/*
** do the initial iteration step
*/
strata[nused-1] =1;
loglik[1] =0;
for (i=0; i<nvar; i++) {
u[i] =0;
a2[i] =0;
for (j=0; j<nvar; j++) {
imat[i][j] =0 ;
cmat2[i][j] =0;
}
}
for (person=nused-1; person>=0; ) {
if (strata[person] == 1) {
nrisk =0 ;
denom = 0;
for (i=0; i<nvar; i++) {
a[i] = 0;
for (j=0; j<nvar; j++) cmat[i][j] = 0;
}
}
dtime = time[person];
ndead =0; /*number of deaths at this time point */
deadwt =0; /* sum of weights for the deaths */
efronwt=0; /* sum of weighted risks for the deaths */
while(person >=0 &&time[person]==dtime) {
/* walk through the this set of tied times */
nrisk++;
zbeta = offset[person]; /* form the term beta*z (vector mult) */
for (i=0; i<nvar; i++)
zbeta += beta[i]*covar[i][person];
zbeta = coxsafe(zbeta);
risk = exp(zbeta) * weights[person];
denom += risk;
/* a is the vector of weighted sums of x, cmat sums of squares */
for (i=0; i<nvar; i++) {
a[i] += risk*covar[i][person];
for (j=0; j<=i; j++)
cmat[i][j] += risk*covar[i][person]*covar[j][person];
}
if (status[person]==1) {
ndead++;
deadwt += weights[person];
efronwt += risk;
loglik[1] += weights[person]*zbeta;
for (i=0; i<nvar; i++)
u[i] += weights[person]*covar[i][person];
if (method==1) { /* Efron */
for (i=0; i<nvar; i++) {
a2[i] += risk*covar[i][person];
for (j=0; j<=i; j++)
cmat2[i][j] += risk*covar[i][person]*covar[j][person];
}
}
}
person--;
if (strata[person]==1) break; /*ties don't cross strata */
}
if (ndead >0) { /* we need to add to the main terms */
if (method==0) { /* Breslow */
loglik[1] -= deadwt* log(denom);
for (i=0; i<nvar; i++) {
temp2= a[i]/ denom; /* mean */
u[i] -= deadwt* temp2;
for (j=0; j<=i; j++)
imat[j][i] += deadwt*(cmat[i][j] - temp2*a[j])/denom;
}
}
else { /* Efron */
/*
** If there are 3 deaths we have 3 terms: in the first the
** three deaths are all in, in the second they are 2/3
** in the sums, and in the last 1/3 in the sum. Let k go
** from 0 to (ndead -1), then we will sequentially use
** denom - (k/ndead)*efronwt as the denominator
** a - (k/ndead)*a2 as the "a" term
** cmat - (k/ndead)*cmat2 as the "cmat" term
** and reprise the equations just above.
*/
for (k=0; k<ndead; k++) {
temp = (double)k/ ndead;
wtave = deadwt/ndead;
d2 = denom - temp*efronwt;
loglik[1] -= wtave* log(d2);
for (i=0; i<nvar; i++) {
temp2 = (a[i] - temp*a2[i])/ d2;
u[i] -= wtave *temp2;
for (j=0; j<=i; j++)
imat[j][i] += (wtave/d2) *
((cmat[i][j] - temp*cmat2[i][j]) -
temp2*(a[j]-temp*a2[j]));
}
}
for (i=0; i<nvar; i++) {
a2[i]=0;
for (j=0; j<nvar; j++) cmat2[i][j]=0;
}
}
}
} /* end of accumulation loop */
loglik[0] = loglik[1]; /* save the loglik for iter 0 */
/* am I done?
** update the betas and test for convergence
*/
for (i=0; i<nvar; i++) /*use 'a' as a temp to save u0, for the score test*/
a[i] = u[i];
*flag= cholesky2(imat, nvar, toler);
chsolve2(imat,nvar,a); /* a replaced by a *inverse(i) */
temp=0;
for (i=0; i<nvar; i++)
temp += u[i]*a[i];
*sctest = temp; /* score test */
/*
** Never, never complain about convergence on the first step. That way,
** if someone HAS to they can force one iter at a time.
*/
for (i=0; i<nvar; i++) {
newbeta[i] = beta[i] + a[i];
}
if (maxiter==0) {
chinv2(imat,nvar);
for (i=0; i<nvar; i++) {
beta[i] *= scale[i]; /*return to original scale */
u[i] /= scale[i];
imat[i][i] *= scale[i]*scale[i];
for (j=0; j<i; j++) {
imat[j][i] *= scale[i]*scale[j];
imat[i][j] = imat[j][i];
}
}
goto finish;
}
/*
** here is the main loop
*/
halving =0 ; /* =1 when in the midst of "step halving" */
for (*iter=1; *iter<= maxiter; (*iter)++) {
newlk =0;
for (i=0; i<nvar; i++) {
u[i] =0;
for (j=0; j<nvar; j++)
imat[i][j] =0;
}
/*
** The data is sorted from smallest time to largest
** Start at the largest time, accumulating the risk set 1 by 1
*/
for (person=nused-1; person>=0; ) {
if (strata[person] == 1) { /* rezero temps for each strata */
denom = 0;
nrisk =0;
for (i=0; i<nvar; i++) {
a[i] = 0;
for (j=0; j<nvar; j++) cmat[i][j] = 0;
}
}
dtime = time[person];
deadwt =0;
ndead =0;
efronwt =0;
while(person>=0 && time[person]==dtime) {
nrisk++;
zbeta = offset[person];
for (i=0; i<nvar; i++)
zbeta += newbeta[i]*covar[i][person];
zbeta = coxsafe(zbeta);
risk = exp(zbeta) * weights[person];
denom += risk;
for (i=0; i<nvar; i++) {
a[i] += risk*covar[i][person];
for (j=0; j<=i; j++)
cmat[i][j] += risk*covar[i][person]*covar[j][person];
}
if (status[person]==1) {
ndead++;
deadwt += weights[person];
newlk += weights[person] *zbeta;
for (i=0; i<nvar; i++)
u[i] += weights[person] *covar[i][person];
if (method==1) { /* Efron */
efronwt += risk;
for (i=0; i<nvar; i++) {
a2[i] += risk*covar[i][person];
for (j=0; j<=i; j++)
cmat2[i][j] += risk*covar[i][person]*covar[j][person];
}
}
}
person--;
if (strata[person]==1) break; /*tied times don't cross strata*/
}
if (ndead >0) { /* add up terms*/
if (method==0) { /* Breslow */
newlk -= deadwt* log(denom);
for (i=0; i<nvar; i++) {
temp2= a[i]/ denom; /* mean */
u[i] -= deadwt* temp2;
for (j=0; j<=i; j++)
imat[j][i] += (deadwt/denom)*
(cmat[i][j] - temp2*a[j]);
}
}
else { /* Efron */
for (k=0; k<ndead; k++) {
temp = (double)k / ndead;
wtave= deadwt/ ndead;
d2= denom - temp* efronwt;
newlk -= wtave* log(d2);
for (i=0; i<nvar; i++) {
temp2 = (a[i] - temp*a2[i])/ d2;
u[i] -= wtave*temp2;
for (j=0; j<=i; j++)
imat[j][i] += (wtave/d2)*
((cmat[i][j] - temp*cmat2[i][j]) -
temp2*(a[j]-temp*a2[j]));
}
}
for (i=0; i<nvar; i++) { /*in anticipation */
a2[i] =0;
for (j=0; j<nvar; j++) cmat2[i][j] =0;
}
}
}
} /* end of accumulation loop */
/* am I done?
** update the betas and test for convergence
*/
*flag = cholesky2(imat, nvar, toler);
if (fabs(1-(loglik[1]/newlk))<= eps && halving==0) { /* all done */
loglik[1] = newlk;
chinv2(imat, nvar); /* invert the information matrix */
for (i=0; i<nvar; i++) {
beta[i] = newbeta[i]*scale[i];
u[i] /= scale[i];
imat[i][i] *= scale[i]*scale[i];
for (j=0; j<i; j++) {
imat[j][i] *= scale[i]*scale[j];
imat[i][j] = imat[j][i];
}
}
goto finish;
}
if (*iter== maxiter) break; /*skip the step halving calc*/
if (newlk < loglik[1]) { /*it is not converging ! */
halving =1;
for (i=0; i<nvar; i++)
newbeta[i] = (newbeta[i] + beta[i]) /2; /*half of old increment */
}
else {
halving=0;
loglik[1] = newlk;
chsolve2(imat,nvar,u);
j=0;
for (i=0; i<nvar; i++) {
beta[i] = newbeta[i];
newbeta[i] = newbeta[i] + u[i];
}
}
} /* return for another iteration */
/*
** We end up here only if we ran out of iterations
*/
loglik[1] = newlk;
chinv2(imat, nvar);
for (i=0; i<nvar; i++) {
beta[i] = newbeta[i]*scale[i];
u[i] /= scale[i];
imat[i][i] *= scale[i]*scale[i];
for (j=0; j<i; j++) {
imat[j][i] *= scale[i]*scale[j];
imat[i][j] = imat[j][i];
}
}
*flag = 1000;
finish:
/*
** create the output list
*/
PROTECT(rlist= allocVector(VECSXP, 8));
SET_VECTOR_ELT(rlist, 0, beta2);
SET_VECTOR_ELT(rlist, 1, means2);
SET_VECTOR_ELT(rlist, 2, u2);
SET_VECTOR_ELT(rlist, 3, imat2);
SET_VECTOR_ELT(rlist, 4, loglik2);
SET_VECTOR_ELT(rlist, 5, sctest2);
SET_VECTOR_ELT(rlist, 6, iter2);
SET_VECTOR_ELT(rlist, 7, flag2);
/* add names to the objects */
PROTECT(rlistnames = allocVector(STRSXP, 8));
SET_STRING_ELT(rlistnames, 0, mkChar("coef"));
SET_STRING_ELT(rlistnames, 1, mkChar("means"));
SET_STRING_ELT(rlistnames, 2, mkChar("u"));
SET_STRING_ELT(rlistnames, 3, mkChar("imat"));
SET_STRING_ELT(rlistnames, 4, mkChar("loglik"));
SET_STRING_ELT(rlistnames, 5, mkChar("sctest"));
SET_STRING_ELT(rlistnames, 6, mkChar("iter"));
SET_STRING_ELT(rlistnames, 7, mkChar("flag"));
setAttrib(rlist, R_NamesSymbol, rlistnames);
unprotect(nprotect+2);
return(rlist);
}
static SEXP readRegistryKey(HKEY hkey, int depth, int view)
{
int i, k = 0, size0, *indx;
SEXP ans, nm, ans0, nm0, tmp, sind;
DWORD res, nsubkeys, maxsubkeylen, nval, maxvalnamlen, size;
wchar_t *name;
HKEY sub;
REGSAM acc = KEY_READ;
if (depth <= 0) return mkString("<subkey>");
if(view == 2) acc |= KEY_WOW64_32KEY;
else if(view == 3) acc |= KEY_WOW64_64KEY;
res = RegQueryInfoKey(hkey, NULL, NULL, NULL,
&nsubkeys, &maxsubkeylen, NULL, &nval,
&maxvalnamlen, NULL, NULL, NULL);
if (res != ERROR_SUCCESS)
error("RegQueryInfoKey error code %d: '%s'", (int) res,
formatError(res));
size0 = max(maxsubkeylen, maxvalnamlen) + 1;
name = (wchar_t *) R_alloc(size0, sizeof(wchar_t));
PROTECT(ans = allocVector(VECSXP, nval + nsubkeys));
PROTECT(nm = allocVector(STRSXP, nval+ nsubkeys));
if (nval > 0) {
PROTECT(ans0 = allocVector(VECSXP, nval));
PROTECT(nm0 = allocVector(STRSXP, nval));
for (i = 0; i < nval; i++) {
size = size0;
res = RegEnumValueW(hkey, i, (LPWSTR) name, &size,
NULL, NULL, NULL, NULL);
if (res != ERROR_SUCCESS) break;
SET_VECTOR_ELT(ans0, i, readRegistryKey1(hkey, name));
SET_STRING_ELT(nm0, i, mkCharUcs(name));
}
/* now sort by name */
PROTECT(sind = allocVector(INTSXP, nval)); indx = INTEGER(sind);
for (i = 0; i < nval; i++) indx[i] = i;
orderVector1(indx, nval, nm0, TRUE, FALSE, R_NilValue);
for (i = 0; i < nval; i++, k++) {
SET_VECTOR_ELT(ans, k, VECTOR_ELT(ans0, indx[i]));
if (LENGTH(tmp = STRING_ELT(nm0, indx[i])))
SET_STRING_ELT(nm, k, tmp);
else
SET_STRING_ELT(nm, k, mkChar("(Default)"));
}
UNPROTECT(3);
}
if (nsubkeys > 0) {
PROTECT(ans0 = allocVector(VECSXP, nsubkeys));
PROTECT(nm0 = allocVector(STRSXP, nsubkeys));
for (i = 0; i < nsubkeys; i++) {
size = size0;
res = RegEnumKeyExW(hkey, i, (LPWSTR) name, &size,
NULL, NULL, NULL, NULL);
if (res != ERROR_SUCCESS) break;
res = RegOpenKeyExW(hkey, (LPWSTR) name, 0, acc, &sub);
if (res != ERROR_SUCCESS) break;
SET_VECTOR_ELT(ans0, i, readRegistryKey(sub, depth-1, view));
SET_STRING_ELT(nm0, i, mkCharUcs(name));
RegCloseKey(sub);
}
/* now sort by name */
PROTECT(sind = allocVector(INTSXP, nsubkeys)); indx = INTEGER(sind);
for (i = 0; i < nsubkeys; i++) indx[i] = i;
orderVector1(indx, nsubkeys, nm0, TRUE, FALSE, R_NilValue);
for (i = 0; i < nsubkeys; i++, k++) {
SET_VECTOR_ELT(ans, k, VECTOR_ELT(ans0, indx[i]));
SET_STRING_ELT(nm, k, STRING_ELT(nm0, indx[i]));
}
UNPROTECT(3);
}
setAttrib(ans, R_NamesSymbol, nm);
UNPROTECT(2);
return ans;
}
SEXP call_zvode(SEXP y, SEXP times, SEXP derivfunc, SEXP parms, SEXP rtol,
SEXP atol, SEXP rho, SEXP tcrit, SEXP jacfunc, SEXP initfunc,
SEXP iTask, SEXP rWork, SEXP iWork, SEXP jT, SEXP nOut,
SEXP lZw, SEXP lRw, SEXP lIw, SEXP Rpar, SEXP Ipar, SEXP flist)
{
/******************************************************************************/
/****** DECLARATION SECTION ******/
/******************************************************************************/
int i, j, k, nt, latol, lrtol, lrw, liw, lzw;
double tin, tout, *Atol, *Rtol, ss;
int neq, itol, itask, istate, iopt, jt, //mflag,
is, isDll, isForcing;
Rcomplex *xytmp, *dy = NULL, *zwork;
int *iwork, it, ntot, nout;
double *rwork;
C_zderiv_func_type *zderiv_func;
C_zjac_func_type *zjac_func = NULL;
/******************************************************************************/
/****** STATEMENTS ******/
/******************************************************************************/
lock_solver(); /* prevent nested call of solvers that have global variables */
/* #### initialisation #### */
//init_N_Protect();
long int old_N_Protect = save_N_Protected();
jt = INTEGER(jT)[0];
neq = LENGTH(y);
nt = LENGTH(times);
nout = INTEGER(nOut)[0];
/* The output:
zout and ipar are used to pass output variables (number set by nout)
followed by other input (e.g. forcing functions) provided
by R-arguments rpar, ipar
ipar[0]: number of output variables, ipar[1]: length of rpar,
ipar[2]: length of ipar */
/* is function a dll ?*/
if (inherits(derivfunc, "NativeSymbol")) {
isDll = 1;
} else {
isDll = 0;
}
/* initialise output for Complex variables ... */
initOutComplex(isDll, &nout, &ntot, neq, nOut, Rpar, Ipar);
/* copies of all variables that will be changed in the FORTRAN subroutine */
xytmp = (Rcomplex *) R_alloc(neq, sizeof(Rcomplex));
for (j = 0; j < neq; j++) xytmp[j] = COMPLEX(y)[j];
latol = LENGTH(atol);
Atol = (double *) R_alloc((int) latol, sizeof(double));
for (j = 0; j < latol; j++) Atol[j] = REAL(atol)[j];
lrtol = LENGTH(rtol);
Rtol = (double *) R_alloc((int) lrtol, sizeof(double));
for (j = 0; j < lrtol; j++) Rtol[j] = REAL(rtol)[j];
liw = INTEGER(lIw)[0];
iwork = (int *) R_alloc(liw, sizeof(int));
for (j = 0; j < 30; j++) iwork[j] = INTEGER(iWork)[j];
lrw = INTEGER(lRw)[0];
rwork = (double *) R_alloc(lrw, sizeof(double));
for (j = 0; j < 20; j++) rwork[j] = REAL(rWork)[j];
/* global variable */
//timesteps = (double *) R_alloc(2, sizeof(double));
for (j=0; j<2; j++) timesteps[j] = 0.;
lzw = INTEGER(lZw)[0];
zwork = (Rcomplex *) R_alloc(lzw, sizeof(Rcomplex));
/* initialise global R-variables... */
PROTECT(cY = allocVector(CPLXSXP , neq) ) ;incr_N_Protect();
PROTECT(YOUT = allocMatrix(CPLXSXP,ntot+1,nt)) ;incr_N_Protect();
/**************************************************************************/
/****** Initialization of Parameters and Forcings (DLL functions) ******/
/**************************************************************************/
initParms(initfunc, parms);
isForcing = initForcings(flist);
/* pointers to functions zderiv_func and zjac_func, passed to the FORTRAN subroutine */
if (isDll == 1) { /* DLL address passed to FORTRAN */
zderiv_func = (C_zderiv_func_type *) R_ExternalPtrAddr(derivfunc);
/* no need to communicate with R - but output variables set here */
if (isOut) {
dy = (Rcomplex *) R_alloc(neq, sizeof(Rcomplex));
/* for (j = 0; j < neq; j++) dy[j] = i0; */
}
/* here overruling zderiv_func if forcing */
if (isForcing) {
DLL_cderiv_func = (C_zderiv_func_type *) R_ExternalPtrAddr(derivfunc);
zderiv_func = (C_zderiv_func_type *) C_zderiv_func_forc;
}
} else {
/* interface function between FORTRAN and R passed to FORTRAN*/
zderiv_func = (C_zderiv_func_type *) C_zderiv_func;
/* needed to communicate with R */
R_zderiv_func = derivfunc;
R_vode_envir = rho;
}
if (!isNull(jacfunc)) {
if (isDll == 1) {
zjac_func = (C_zjac_func_type *) R_ExternalPtrAddr(jacfunc);
} else {
R_zjac_func = jacfunc;
zjac_func = C_zjac_func;
}
}
/* tolerance specifications */
if (latol == 1 && lrtol == 1 ) itol = 1;
if (latol > 1 && lrtol == 1 ) itol = 2;
if (latol == 1 && lrtol > 1 ) itol = 3;
if (latol > 1 && lrtol > 1 ) itol = 4;
itask = INTEGER(iTask)[0];
istate = 1;
iopt = 0;
ss = 0.;
is = 0;
for (i = 5; i < 8 ; i++) ss = ss+rwork[i];
for (i = 5; i < 10; i++) is = is+iwork[i];
if (ss >0 || is > 0) iopt = 1; /* non-standard input */
/* #### initial time step #### */
/* COMPLEX(YOUT)[0] = COMPLEX(times)[0];*/
for (j = 0; j < neq; j++) {
COMPLEX(YOUT)[j+1] = COMPLEX(y)[j];
} /* function in DLL and output */
if (isOut == 1) {
tin = REAL(times)[0];
zderiv_func (&neq, &tin, xytmp, dy, zout, ipar) ;
for (j = 0; j < nout; j++)
COMPLEX(YOUT)[j + neq + 1] = zout[j];
}
/* #### main time loop #### */
for (it = 0; it < nt-1; it++) {
tin = REAL(times)[it];
tout = REAL(times)[it+1];
F77_CALL(zvode) (zderiv_func, &neq, xytmp, &tin, &tout,
&itol, Rtol, Atol, &itask, &istate, &iopt, zwork, &lzw, rwork,
&lrw, iwork, &liw, zjac_func, &jt, zout, ipar);
/* in case size of timesteps is called for */
timesteps [0] = rwork[10];
timesteps [1] = rwork[11];
if (istate == -1) {
warning("an excessive amount of work (> mxstep ) was done, but integration was not successful - increase maxsteps ?");
} else if (istate == -2) {
warning("Excessive precision requested. scale up `rtol' and `atol' e.g by the factor %g\n",10.0);
} else if (istate == -4) {
warning("repeated error test failures on a step, but integration was successful - singularity ?");
} else if (istate == -5) {
warning("repeated convergence test failures on a step, but integration was successful - inaccurate Jacobian matrix?");
} else if (istate == -6) {
warning("Error term became zero for some i: pure relative error control (ATOL(i)=0.0) for a variable which is now vanished");
}
if (istate == -3) {
error("illegal input detected before taking any integration steps - see written message");
unprotect_all();
} else {
/* REAL(YOUT)[(it+1)*(ntot+1)] = tin;*/
for (j = 0; j < neq; j++)
COMPLEX(YOUT)[(it+1)*(ntot + 1) + j + 1] = xytmp[j];
if (isOut == 1) {
zderiv_func (&neq, &tin, xytmp, dy, zout, ipar) ;
for (j = 0; j < nout; j++)
COMPLEX(YOUT)[(it+1)*(ntot + 1) + j + neq + 1] = zout[j];
}
}
/* #### an error occurred #### */
if (istate < 0 || tin < tout) {
warning("Returning early from dvode Results are accurate, as far as they go\n");
/* redimension YOUT */
PROTECT(YOUT2 = allocMatrix(CPLXSXP,ntot+1,(it+2)));incr_N_Protect();
for (k = 0; k < it+2; k++)
for (j = 0; j < ntot+1; j++)
COMPLEX(YOUT2)[k*(ntot+1) + j] = COMPLEX(YOUT)[k*(ntot+1) + j];
break;
}
} /* end main time loop */
/* #### returning output #### */
terminate(istate, iwork, 23, 0, rwork, 4, 10);
unlock_solver();
//unprotect_all();
restore_N_Protected(old_N_Protect);
if (istate > 0)
return(YOUT);
else
return(YOUT2);
}
int oncentb(int *xrows, int *xcols, double *x, int *ncenters,
double *centers, int *cluster, int *clustersize,
int *dist,int *iter,int *itermax, double *par, int *verbose)
{
int k, m, n, chang, a ,seira, minn;
double e, h, l, aa, i,ermin,serror, mindist;
double *dista;
int *ordd;
dista = (double *) R_alloc(*ncenters, sizeof(double));
ordd = (int *) R_alloc(*ncenters, sizeof(int));
ermin=0.0;
serror=0.0;
for(k=0; k<*xrows; k++){
for(m=0; m<*ncenters; m++){
dista[m]=0.0;
}
for(m=0; m<*ncenters; m++){
for(n=0;n<*xcols;n++){
if(*dist == 0){
dista[m] += (x[k+(*xrows)*n] - centers[m +(*ncenters)*n])*(x[k+(*xrows)*n] - centers[m + (*ncenters)*n]);
}
else if(*dist ==1){
dista[m] += fabs(x[k+(*xrows)*n] - centers[m + (*ncenters)*n]);
}
}
}
/*ORDERING ACCORDING TO THE DISTANCE*/
for (m=0;m<*ncenters;m++){
ordd[m]=m;
}
chang=1;
while(chang!=0){
chang=0;
for (m=0;m<(*ncenters-1);m++){
if (dista[m]> dista[m+1]){
aa=dista[m];
dista[m]=dista[m+1];
dista[m+1]=aa;
a=ordd[m];
ordd[m]=ordd[m+1];
ordd[m+1]=a;
chang=chang+1;
}
}
}
/*NEW CENTERS*/
for (m=0;m<*ncenters;m++){
seira=ordd[m];
/*printf("m:%d\n....ord:%d\n",m,seira );*/
i=(double)(((*iter)-1)*(*xrows)+k)/((*itermax)*(*xrows));
e=par[0]*pow(par[1]/par[0],i);
l=par[2]*pow(par[3]/par[2],i);
h=exp(-(double)m/l);
/* printf("par: %f, %f, i:%f\n", par[0], par[2], i);
printf("m: %i, seira: %i\n", m,seira); */
for (n=0; n<*xcols;n++){
centers[seira+(*ncenters)*n]+=e*h*(x[k+(*xrows)*n]-centers[seira+(*ncenters)*n]);
}
/* printf("\n");*/
}
}
for (k=0;k<*xrows;k++){
mindist=0.0;/*just to avoid compiling warnings*/
minn=0; /*the same reason*/
for (m=0;m<*ncenters;m++){
dista[m] = 0.0;
for(n=0;n<*xcols;n++){
if(*dist == 0){
dista[m] += (x[k+(*xrows)*n] -
centers[m+(*ncenters)*n])*
(x[k+(*xrows)*n] - centers[m + (*ncenters)*n]);
}
else if(*dist ==1){
dista[m] += fabs(x[k+(*xrows)*n] -
centers[m + (*ncenters)*n]);
}
}
if (m == 0)
{
mindist = dista[0]; minn = 0;
}
else
{
if (dista[m] < mindist)
{
mindist = dista[m];
minn = m;
}
}
}
cluster[k] = minn;
}
/*ERROR MINIMIZATION*/
for (m=0;m<*ncenters;m++){
for (k=0;k<*xrows;k++){
if (cluster[k]==m){
for(n=0;n<*xcols;n++){
if(*dist == 0){
serror += (x[k+(*xrows)*n] - centers[m
+(*ncenters)*n])*(x[k+(*xrows)*n] - centers[m +(*ncenters)*n]);
}
else if(*dist ==1){
serror += fabs(x[k+(*xrows)*n] - centers[m + (*ncenters)*n]);
}
}
}
}
}
ermin=(serror)/(*xrows);
/*if (*iter==1 | *iter==*itermax){*/
if (*verbose){
Rprintf("Iteration: %3d Error: %13.10f\n",*iter,ermin);
}
/*}*/
/* printf("Iter:%d\n...",*iter);*/
return 0;
}
SEXP attribute_hidden do_fft(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP z, d;
int i, inv, maxf, maxmaxf, maxmaxp, maxp, n, ndims, nseg, nspn;
double *work;
int *iwork;
checkArity(op, args);
z = CAR(args);
switch (TYPEOF(z)) {
case INTSXP:
case LGLSXP:
case REALSXP:
z = coerceVector(z, CPLXSXP);
break;
case CPLXSXP:
if (NAMED(z)) z = duplicate(z);
break;
default:
error(_("non-numeric argument"));
}
PROTECT(z);
/* -2 for forward transform, complex values */
/* +2 for backward transform, complex values */
inv = asLogical(CADR(args));
if (inv == NA_INTEGER || inv == 0)
inv = -2;
else
inv = 2;
if (LENGTH(z) > 1) {
if (isNull(d = getAttrib(z, R_DimSymbol))) { /* temporal transform */
n = length(z);
fft_factor(n, &maxf, &maxp);
if (maxf == 0)
error(_("fft factorization error"));
work = (double*)R_alloc(4 * maxf, sizeof(double));
iwork = (int*)R_alloc(maxp, sizeof(int));
fft_work(&(COMPLEX(z)[0].r), &(COMPLEX(z)[0].i),
1, n, 1, inv, work, iwork);
}
else { /* spatial transform */
maxmaxf = 1;
maxmaxp = 1;
ndims = LENGTH(d);
/* do whole loop just for error checking and maxmax[fp] .. */
for (i = 0; i < ndims; i++) {
if (INTEGER(d)[i] > 1) {
fft_factor(INTEGER(d)[i], &maxf, &maxp);
if (maxf == 0)
error(_("fft factorization error"));
if (maxf > maxmaxf)
maxmaxf = maxf;
if (maxp > maxmaxp)
maxmaxp = maxp;
}
}
work = (double*)R_alloc(4 * maxmaxf, sizeof(double));
iwork = (int*)R_alloc(maxmaxp, sizeof(int));
nseg = LENGTH(z);
n = 1;
nspn = 1;
for (i = 0; i < ndims; i++) {
if (INTEGER(d)[i] > 1) {
nspn *= n;
n = INTEGER(d)[i];
nseg /= n;
fft_factor(n, &maxf, &maxp);
fft_work(&(COMPLEX(z)[0].r), &(COMPLEX(z)[0].i),
nseg, n, nspn, inv, work, iwork);
}
}
}
}
UNPROTECT(1);
return z;
}
/* A function for reading compact format files.
* Use with the .Call interface function.
* Written by Mikko Korpela
*/
SEXP rcompact(SEXP filename){
char field_id, line[LINE_LENGTH], mplier_str[MPLIER_LENGTH], *found1,
*found2, *found_leftpar, *found_dot, *found_rightpar, *found_tilde,
*id_start, *old_point, *point, *point2, *endp, *tmp_name,
*tmp_comment;
int i, j, n, first_yr, last_yr, id_length, exponent,
n_repeats, field_width, n_x_w, n_lines, remainder, idx,
this_last, *i_first, *i_last;
long int precision;
size_t idx2;
Rboolean n_found, divide;
long long int read_int;
double read_double, mplier, *r_mplier, *r_data;
FILE *f;
SEXP result, series_id, series_first, series_last, series_mplier,
series_data, project_comments;
rwlnode first, *this;
commentnode comment_first, *comment_this;
double divisor = 1; /* assign a value to avoid compiler nag */
int n_content = 0;
int n_comments = 0;
Rboolean early_eof = FALSE;
/* Open the file for reading */
const char *fname = CHAR(STRING_ELT(filename, 0));
f = fopen(fname, "r");
if(f == NULL)
error(_("Could not open file %s for reading"), fname);
this = &first; /* current rwlnode */
comment_this = &comment_first; /* current commentnode */
n = 0; /* number of series */
first_yr = R_INT_MAX; /* the first year in all data */
last_yr = R_INT_MIN; /* the last year in all data */
/* Each round of the loop reads a header line,
* then the data lines of the corresponding series
*/
while(fgets_eol(line, &n_content, LINE_LENGTH, f) != NULL){
/* In the beginning of the file, if no ~ is found, we assume
* the line is a comment. This is the same approach as in the
* TRiCYCLE program.
*/
while(strchr(line, '~') == NULL){
if(n_content > 0){ /* Skip empty lines */
if(n_comments == R_INT_MAX)
error(_("Number of comments exceeds integer range"));
++n_comments;
tmp_comment = (char *) R_alloc(n_content+1, sizeof(char));
strncpy(tmp_comment, line, n_content);
tmp_comment[n_content] = '\0'; /* Null termination */
comment_this->text = tmp_comment;
comment_this->next =
(commentnode *) R_alloc(1, sizeof(commentnode));
comment_this = comment_this->next;
}
if(fgets_eol(line, &n_content, LINE_LENGTH, f) == NULL){
early_eof = TRUE;
break;
}
}
if(early_eof == TRUE)
break;
if(n == R_INT_MAX)
error(_("Number of series exceeds integer range"));
/* A simple check to point out too long header
* lines. Generally, if one line is too long, this function
* will probably be unable to parse the next line. In that
* case, finding the faulty line may be of some value. Of
* course, if the input is generated by some program, lines
* are expected to be short enough. Data edited by hand may be
* a different case.
*/
if(n_content > CONTENT_LENGTH){
fclose(f);
error(_("Series %d: Header line is too long (max length %d)"),
n+1, CONTENT_LENGTH);
}
n_found = FALSE;
/* Find the first '=' character (N or I field) */
found1 = strchr(line, '=');
/* Not a header line, not a valid file */
if(found1 == NULL){
fclose(f);
error(_("Series %d: No '=' found when header line was expected"),
n+1);
}
if(found1 == line){
fclose(f);
error(_("Series %d: No room for number before first '='"), n+1);
}
/* Convert the part left of the first '=' to an integer */
read_int = strtoll(line, &endp, 10);
if(endp != found1){
fclose(f);
error(_("Series %d: Only a number must be found right before 1st '='"),
n+1);
}
if(read_int > R_INT_MAX || read_int < R_INT_MIN){
fclose(f);
error(_("Series %d: Number %lld exceeds integer range"),
n+1, read_int);
}
/* We assume the field id is right after the '=' */
field_id = toupper((unsigned char)(*(found1+1)));
/* We allow N (n) and I (i) fields in either order */
if(field_id == 'N'){
n_found = TRUE;
if(read_int <= 0){
fclose(f);
error(_("Series %d: Length of series must be at least one (%ld seen)"),
n+1, read_int);
}
this->n = (int) read_int;
} else if(field_id == 'I'){
this->first_yr = (int) read_int;
} else{
fclose(f);
error(_("Series %d: Unknown field id: %c"), n+1, *(found1+1));
}
/* Require space */
if(*(found1+2) != ' '){
fclose(f);
error(_("Series %d: Space required between N and I fields"), n+1);
}
/* Find the second '=' character (I or N field) */
found2 = strchr(found1+3, '=');
if(found2 == NULL){
fclose(f);
error(_("Series %d: Second '=' missing"), n+1);
}
if(found2 == found1+3){
fclose(f);
error(_("Series %d: No room for number before second '='"), n+1);
}
read_int = strtoll(found1+3, &endp, 10);
if(endp != found2){
fclose(f);
error(_("Series %d: Only a number must be found after first field, right before 2nd '='"),
n+1);
}
if(read_int > R_INT_MAX || read_int < R_INT_MIN){
fclose(f);
error(_("Series %d: Number %lld exceeds integer range"),
n+1, read_int);
}
field_id = toupper((unsigned char)(*(found2+1)));
if(n_found == TRUE && field_id == 'I'){
this->first_yr = (int) read_int;
} else if(field_id == 'N'){
if(read_int <= 0){
fclose(f);
error(_("Series %d: Length of series must be at least one (%ld seen)"),
n+1, read_int);
}
this->n = (int) read_int;
} else{
fclose(f);
error(_("Series %d: Unknown or doubled field id: %c"),
n+1, *(found2+1));
}
/* Check for overflow */
if(this->first_yr > 1 && this->n - 1 > R_INT_MAX - this->first_yr)
error(_("Series %d: Last year exceeds integer range"), n+1);
/* Update global first and last year */
if(this->first_yr < first_yr)
first_yr = this->first_yr;
this_last = this->first_yr + (this->n - 1);
if(this_last > last_yr)
last_yr = this_last;
point = found2+2;
/* Require one space */
if(*point != ' '){
fclose(f);
error(_("Series %d (%s): Space required before ID"),
n+1, this->id);
} else {
++point;
}
/* Skip further spaces */
while(*point == ' ')
++point;
/* Find last character of series id */
found_tilde = strchr(point+1, '~');
if(found_tilde == NULL || found_tilde < point + 2){
error(_("Series %d (%s): '~' not found in expected location"),
n+1, this->id);
fclose(f);
}
point2 = found_tilde - 1;
while(*point2 != ' ' && point2 > point + 1)
--point2;
--point2;
while(*point2 == ' ')
--point2;
/* Read series id */
if(isprint((unsigned char)(*point))){
id_start = point;
++point;
while(point < point2 + 1){
if(!isprint((unsigned char)(*point))){
fclose(f);
error(_("Series %d: Invalid character in series ID"), n+1);
}
++point;
}
id_length = (int)(point - id_start);
tmp_name = (char *) R_alloc(id_length+1, sizeof(char));
strncpy(tmp_name, id_start, id_length);
tmp_name[id_length] = '\0'; /* Null termination */
this->id = tmp_name;
} else {
fclose(f);
error(_("Series %d: Alphanumeric series ID not found"), n+1);
}
/* Require space */
if(*point != ' '){
fclose(f);
error(_("Series %d (%s): Space required after alphanumeric ID"),
n+1, this->id);
}
/* Read number format description, must be <exp>(<n>F<w>.<d>)~ */
++point;
exponent = (int) strtol(point, &endp, 10);
if(endp == point){
fclose(f);
error(_("Series %d (%s): Exponent not found"),
n+1, this->id);
}
if(exponent < 0){
exponent = -exponent;
divide = TRUE;
} else{
divide = FALSE;
}
if(snprintf(mplier_str, MPLIER_LENGTH, "1e%d", exponent) >=
MPLIER_LENGTH){
fclose(f);
error(_("Series %d (%s): Exponent has too many characters"),
n+1, this->id);
}
if(*endp != '('){
fclose(f);
error(_("Series %d (%s): Opening parenthesis required after exponent"),
n+1, this->id);
}
found_leftpar = endp;
found_dot = strchr(found_leftpar+1, '.');
if(found_dot == NULL){
fclose(f);
error(_("Series %d (%s): No dot found in number format description"),
n+1, this->id);
}
found_rightpar = strchr(found_dot+1, ')');
if(found_rightpar == NULL){
fclose(f);
error(_("Series %d (%s): No closing parenthesis found"),
n+1, this->id);
}
if(divide == TRUE){
divisor = strtod(mplier_str, NULL);
mplier = 1 / divisor; /* Only for information purpose */
} else{
mplier = strtod(mplier_str, NULL);
}
this->mplier = mplier;
point = found_leftpar+1;
n_repeats = (int) strtol(point, &endp, 10);
if(endp == point){
fclose(f);
error(_("Series %d (%s): Number of values per line not found"),
n+1, this->id);
}
if(n_repeats < 1){
fclose(f);
error(_("Series %d (%s): At least one value per line is needed"),
n+1, this->id);
}
if(n_repeats > CONTENT_LENGTH){
fclose(f);
error(_("Series %d (%s): Number of values per line (%d) > max line length (%d)"),
n+1, this->id, n_repeats, CONTENT_LENGTH);
}
if(*endp != 'F'){
fclose(f);
error(_("Series %d (%s): Only 'F' number format is supported"),
n+1, this->id);
}
point = endp+1;
field_width = (int) strtol(point, &endp, 10);
if(endp == point){
fclose(f);
error(_("Series %d (%s): Field width not found"),
n+1, this->id);
}
if(endp != found_dot){
fclose(f);
error(_("Series %d (%s): Field width and '.' must be adjacent"),
n+1, this->id);
}
if(field_width < 1){
fclose(f);
error(_("Series %d (%s): Field width must be at least one (%d seen)"),
n+1, this->id, field_width);
}
point = found_dot+1;
precision = strtol(point, &endp, 10);
if(endp == point){
fclose(f);
error(_("Series %d (%s): Number of decimals not found"),
n+1, this->id);
}
if(endp != found_rightpar){
fclose(f);
error(_("Series %d (%s): Number of decimals and ')' must be adjacent"),
n+1, this->id);
}
if(precision != 0L){
fclose(f);
error(_("Series %d (%s): No (implied) decimal places allowed in format"),
n+1, this->id);
}
n_x_w = n_repeats * field_width;
if(n_x_w > CONTENT_LENGTH){
fclose(f);
error(_("Series %d (%s): Required line length %d exceeds the maximum %d"),
n+1, this->id, n_x_w, CONTENT_LENGTH);
}
/* Temporary storage for the data on the following lines */
this->data = (double *) R_alloc(this->n, sizeof(double));
/* Number of full-length lines (integer division truncates) */
n_lines = this->n / n_repeats;
/* Number of values on the (possible) left-over line */
remainder = this->n - n_lines * n_repeats;
/* Read the data (full lines) */
idx = -n_repeats;
for(i=0; i<n_lines; i++){
if(fgets_eol(line, &n_content, LINE_LENGTH, f) == NULL){
fclose(f);
error(_("Series %d (%s): Unexpected end of file (%d data lines read)"),
n+1, this->id, i);
}
if((remainder > 0 || !feof(f)) &&
n_content > CONTENT_LENGTH){
fclose(f);
error(_("Series %d (%s): Data line %d is too long (max length %d)"),
n+1, this->id, i+1, CONTENT_LENGTH);
}
point = line + n_x_w;
idx += n_repeats << 1;
/* Read backwards */
for(j=0; j<n_repeats; j++){
*point = '\0'; /* overwrite is OK because number has been read */
old_point = point;
point -= field_width; /* pick a piece of field_width characters */
read_double = strtod(point, &endp);
if(endp != old_point){ /* numbers must be right aligned */
fclose(f);
error(_("Series %d (%s): Could not read number (data row %d, field %d).\nMalformed number or previous line too long."),
n+1, this->id, i+1, n_repeats-j);
}
/* Division by a precise number (integer value) is
* more accurate than multiplication with an
* approximate number. Example from R:
* > foo=seq(0,1,length.out=100)
* > length(which(foo/100!=foo*0.01))
* [1] 10
*/
if(divide == TRUE)
this->data[--idx] = read_double / divisor;
else
this->data[--idx] = read_double * mplier;
}
}
/* Read the data (possibly remaining shorter line) */
if(remainder > 0){
if(fgets_eol(line, &n_content, LINE_LENGTH, f) == NULL){
fclose(f);
error(_("Series %d (%s): Unexpected end of file (%d data lines read)"),
n+1, this->id, n_lines);
}
if(!feof(f) && n_content > CONTENT_LENGTH){
fclose(f);
error(_("Series %d (%s): Data line %d is too long (max length %d)"),
n+1, this->id, n_lines+1, CONTENT_LENGTH);
}
point = line + remainder * field_width;
idx += n_repeats + remainder;
for(j=0; j<remainder; j++){
*point = '\0';
old_point = point;
point -= field_width;
read_double = strtod(point, &endp);
if(endp != old_point){
fclose(f);
error(_("Series %d (%s): Could not read number (data row %d, field %d).\nMalformed number or previous line too long."),
n+1, this->id, n_lines+1, remainder-j);
}
if(divide == TRUE)
this->data[--idx] = read_double / divisor;
else
this->data[--idx] = read_double * mplier;
}
}
/* Prepare for possible next round of the loop (next series) */
this->next = (rwlnode *) R_alloc(1, sizeof(rwlnode));
this = this->next;
++n;
}
if(ferror(f)){
fclose(f);
error(_("Error reading file %s"), fname);
}
/* Close the file (ignore return value) */
fclose(f);
if(n == 0)
error(_("No data found in file %s"), fname);
/* Transform the results to a list with 7 elements */
PROTECT(result = allocVector(VECSXP, 8));
/* [[1]] First year of all data */
SET_VECTOR_ELT(result, 0, ScalarInteger(first_yr));
/* [[2]] Last year of all data */
SET_VECTOR_ELT(result, 1, ScalarInteger(last_yr));
/* [[3]] Series ID */
PROTECT(series_id = allocVector(STRSXP, n));
/* [[4]] First year of series */
PROTECT(series_first = allocVector(INTSXP, n));
/* [[5]] Last year of series */
PROTECT(series_last = allocVector(INTSXP, n));
/* [[6]] Multiplier (precision) */
PROTECT(series_mplier = allocVector(REALSXP, n));
/* [[7]] Numeric data (ring widths) */
PROTECT(series_data = allocMatrix(REALSXP, last_yr - first_yr + 1, n));
/* [[8]] Project comments */
PROTECT(project_comments = allocVector(STRSXP, n_comments));
/* C access to the last four R data structures.
* - first two (scalars, i.e. vector of length one) already done
* - SET_STRING_ELT is used for accessing the character vector
*/
i_first = INTEGER(series_first);
i_last = INTEGER(series_last);
r_mplier = REAL(series_mplier);
r_data = REAL(series_data);
/* idx2 is for indexing r_data.
* The matrix series_data is stored in column-major order: We
* proceed one series at a time, simply incrementing idx2 on each
* (carefully planned) write to the array.
*/
idx2 = 0;
this = &first;
for(i=0; i<n; i++){
this_last = this->first_yr + (this->n - 1);
SET_STRING_ELT(series_id, i, mkChar(this->id));
i_first[i] = this->first_yr;
i_last[i] = this_last;
r_mplier[i] = this->mplier;
/* Add NA to beginning */
for(j=0; j < this->first_yr - first_yr; j++)
r_data[idx2++] = NA_REAL;
/* Add data to middle */
for(j=0; j < this->n; j++)
r_data[idx2++] = this->data[j];
/* Add NA to end */
for(j=0; j < last_yr - this_last; j++)
r_data[idx2++] = NA_REAL;
this = this->next;
}
comment_this = &comment_first;
for(i=0; i<n_comments; i++){
SET_STRING_ELT(project_comments, i, mkChar(comment_this->text));
comment_this = comment_this->next;
}
SET_VECTOR_ELT(result, 7, project_comments);
SET_VECTOR_ELT(result, 6, series_data);
SET_VECTOR_ELT(result, 5, series_mplier);
SET_VECTOR_ELT(result, 4, series_last);
SET_VECTOR_ELT(result, 3, series_first);
SET_VECTOR_ELT(result, 2, series_id);
UNPROTECT(7);
return(result);
}
SEXP nlm(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP value, names, v, R_gradientSymbol, R_hessianSymbol;
double *x, *typsiz, fscale, gradtl, stepmx,
steptol, *xpls, *gpls, fpls, *a, *wrk, dlt;
int code, i, j, k, itnlim, method, iexp, omsg, msg,
n, ndigit, iagflg, iahflg, want_hessian, itncnt;
/* .Internal(
* nlm(function(x) f(x, ...), p, hessian, typsize, fscale,
* msg, ndigit, gradtol, stepmax, steptol, iterlim)
*/
function_info *state;
args = CDR(args);
PrintDefaults();
state = (function_info *) R_alloc(1, sizeof(function_info));
/* the function to be minimized */
v = CAR(args);
if (!isFunction(v))
error(_("attempt to minimize non-function"));
PROTECT(state->R_fcall = lang2(v, R_NilValue));
args = CDR(args);
/* `p' : inital parameter value */
n = 0;
x = fixparam(CAR(args), &n);
args = CDR(args);
/* `hessian' : H. required? */
want_hessian = asLogical(CAR(args));
if (want_hessian == NA_LOGICAL) want_hessian = 0;
args = CDR(args);
/* `typsize' : typical size of parameter elements */
typsiz = fixparam(CAR(args), &n);
args = CDR(args);
/* `fscale' : expected function size */
fscale = asReal(CAR(args));
if (ISNA(fscale)) error(_("invalid NA value in parameter"));
args = CDR(args);
/* `msg' (bit pattern) */
omsg = msg = asInteger(CAR(args));
if (msg == NA_INTEGER) error(_("invalid NA value in parameter"));
args = CDR(args);
ndigit = asInteger(CAR(args));
if (ndigit == NA_INTEGER) error(_("invalid NA value in parameter"));
args = CDR(args);
gradtl = asReal(CAR(args));
if (ISNA(gradtl)) error(_("invalid NA value in parameter"));
args = CDR(args);
stepmx = asReal(CAR(args));
if (ISNA(stepmx)) error(_("invalid NA value in parameter"));
args = CDR(args);
steptol = asReal(CAR(args));
if (ISNA(steptol)) error(_("invalid NA value in parameter"));
args = CDR(args);
/* `iterlim' (def. 100) */
itnlim = asInteger(CAR(args));
if (itnlim == NA_INTEGER) error(_("invalid NA value in parameter"));
state->R_env = rho;
/* force one evaluation to check for the gradient and hessian */
iagflg = 0; /* No analytic gradient */
iahflg = 0; /* No analytic hessian */
state->have_gradient = 0;
state->have_hessian = 0;
R_gradientSymbol = install("gradient");
R_hessianSymbol = install("hessian");
/* This vector is shared with all subsequent calls */
v = allocVector(REALSXP, n);
for (i = 0; i < n; i++) REAL(v)[i] = x[i];
SETCADR(state->R_fcall, v);
SET_NAMED(v, 2); // in case the functions try to alter it
value = eval(state->R_fcall, state->R_env);
v = getAttrib(value, R_gradientSymbol);
if (v != R_NilValue) {
if (LENGTH(v) == n && (isReal(v) || isInteger(v))) {
iagflg = 1;
state->have_gradient = 1;
v = getAttrib(value, R_hessianSymbol);
if (v != R_NilValue) {
if (LENGTH(v) == (n * n) && (isReal(v) || isInteger(v))) {
iahflg = 1;
state->have_hessian = 1;
} else {
warning(_("hessian supplied is of the wrong length or mode, so ignored"));
}
}
} else {
warning(_("gradient supplied is of the wrong length or mode, so ignored"));
}
}
if (((msg/4) % 2) && !iahflg) { /* skip check of analytic Hessian */
msg -= 4;
}
if (((msg/2) % 2) && !iagflg) { /* skip check of analytic gradient */
msg -= 2;
}
FT_init(n, FT_SIZE, state);
/* Plug in the call to the optimizer here */
method = 1; /* Line Search */
iexp = iahflg ? 0 : 1; /* Function calls are expensive */
dlt = 1.0;
xpls = (double*)R_alloc(n, sizeof(double));
gpls = (double*)R_alloc(n, sizeof(double));
a = (double*)R_alloc(n*n, sizeof(double));
wrk = (double*)R_alloc(8*n, sizeof(double));
/*
* Dennis + Schnabel Minimizer
*
* SUBROUTINE OPTIF9(NR,N,X,FCN,D1FCN,D2FCN,TYPSIZ,FSCALE,
* + METHOD,IEXP,MSG,NDIGIT,ITNLIM,IAGFLG,IAHFLG,IPR,
* + DLT,GRADTL,STEPMX,STEPTOL,
* + XPLS,FPLS,GPLS,ITRMCD,A,WRK)
*
*
* Note: I have figured out what msg does.
* It is actually a sum of bit flags as follows
* 1 = don't check/warn for 1-d problems
* 2 = don't check analytic gradients
* 4 = don't check analytic hessians
* 8 = don't print start and end info
* 16 = print at every iteration
* Using msg=9 is absolutely minimal
* I think we always check gradients and hessians
*/
optif9(n, n, x, (fcn_p) fcn, (fcn_p) Cd1fcn, (d2fcn_p) Cd2fcn,
state, typsiz, fscale, method, iexp, &msg, ndigit, itnlim,
iagflg, iahflg, dlt, gradtl, stepmx, steptol, xpls, &fpls,
gpls, &code, a, wrk, &itncnt);
if (msg < 0)
opterror(msg);
if (code != 0 && (omsg&8) == 0)
optcode(code);
if (want_hessian) {
PROTECT(value = allocVector(VECSXP, 6));
PROTECT(names = allocVector(STRSXP, 6));
fdhess(n, xpls, fpls, (fcn_p) fcn, state, a, n, &wrk[0], &wrk[n],
ndigit, typsiz);
for (i = 0; i < n; i++)
for (j = 0; j < i; j++)
a[i + j * n] = a[j + i * n];
}
else {
PROTECT(value = allocVector(VECSXP, 5));
PROTECT(names = allocVector(STRSXP, 5));
}
k = 0;
SET_STRING_ELT(names, k, mkChar("minimum"));
SET_VECTOR_ELT(value, k, ScalarReal(fpls));
k++;
SET_STRING_ELT(names, k, mkChar("estimate"));
SET_VECTOR_ELT(value, k, allocVector(REALSXP, n));
for (i = 0; i < n; i++)
REAL(VECTOR_ELT(value, k))[i] = xpls[i];
k++;
SET_STRING_ELT(names, k, mkChar("gradient"));
SET_VECTOR_ELT(value, k, allocVector(REALSXP, n));
for (i = 0; i < n; i++)
REAL(VECTOR_ELT(value, k))[i] = gpls[i];
k++;
if (want_hessian) {
SET_STRING_ELT(names, k, mkChar("hessian"));
SET_VECTOR_ELT(value, k, allocMatrix(REALSXP, n, n));
for (i = 0; i < n * n; i++)
REAL(VECTOR_ELT(value, k))[i] = a[i];
k++;
}
SET_STRING_ELT(names, k, mkChar("code"));
SET_VECTOR_ELT(value, k, allocVector(INTSXP, 1));
INTEGER(VECTOR_ELT(value, k))[0] = code;
k++;
/* added by Jim K Lindsey */
SET_STRING_ELT(names, k, mkChar("iterations"));
SET_VECTOR_ELT(value, k, allocVector(INTSXP, 1));
INTEGER(VECTOR_ELT(value, k))[0] = itncnt;
k++;
setAttrib(value, R_NamesSymbol, names);
UNPROTECT(3);
return value;
}
int_node* gen_int_node(int_vec* unit)
{ int_node *newnode = (int_node*) R_alloc(1,sizeof(*newnode));
newnode -> value = unit;
newnode -> next = NULL;
return newnode;
}
int* gen_int_array(int la)
{ if(la > 0)
return((int*) R_alloc(la,sizeof(int)));
else return NULL;
}
static void predictions(char **casev,
char **namesv,
char **treev,
char **rulesv,
char **costv,
int *predv, /* XXX predictions are character */
double *confidencev,
int *trials,
char **outputv)
{
int val; /* Used by setjmp/longjmp for implementing rbm_exit */
// Announce ourselves for testing
// Rprintf("predictions called\n");
// Initialize the globals
initglobals();
// Handles the strbufv data structure
rbm_removeall();
// XXX Should this be controlled via an option?
// Rprintf("Calling setOf\n");
setOf();
STRBUF *sb_cases = strbuf_create_full(*casev, strlen(*casev));
if (rbm_register(sb_cases, "undefined.cases", 0) < 0) {
error("undefined.cases already exists");
}
STRBUF *sb_names = strbuf_create_full(*namesv, strlen(*namesv));
if (rbm_register(sb_names, "undefined.names", 0) < 0) {
error("undefined.names already exists");
}
if (strlen(*treev)) {
STRBUF *sb_treev = strbuf_create_full(*treev, strlen(*treev));
/* XXX should sb_treev be copied? */
if (rbm_register(sb_treev, "undefined.tree", 0) < 0) {
error("undefined.tree already exists");
}
} else if (strlen(*rulesv)) {
STRBUF *sb_rulesv = strbuf_create_full(*rulesv, strlen(*rulesv));
/* XXX should sb_rulesv be copied? */
if (rbm_register(sb_rulesv, "undefined.rules", 0) < 0) {
error("undefined.rules already exists");
}
setrules(1);
} else {
error("either a tree or rules must be provided");
}
// Create a strbuf using *costv and register it as "undefined.costs"
if (strlen(*costv) > 0) {
// Rprintf("registering cost matrix: %s", *costv);
STRBUF *sb_costv = strbuf_create_full(*costv, strlen(*costv));
// XXX should sb_costv be copied?
if (rbm_register(sb_costv, "undefined.costs", 0) < 0) {
error("undefined.cost already exists");
}
} else {
// Rprintf("no cost matrix to register\n");
}
/*
* We need to initialize rbm_buf before calling any code that
* might call exit/rbm_exit.
*/
if ((val = setjmp(rbm_buf)) == 0) {
// Real work is done here
// Rprintf("\n\nCalling rpredictmain\n");
rpredictmain(trials ,predv ,confidencev);
// Rprintf("predict finished\n\n");
} else {
Rprintf("predict code called exit with value %d\n\n", val - JMP_OFFSET);
}
// Close file object "Of", and return its contents via argument outputv
char *outputString = closeOf();
char *output = R_alloc(strlen(outputString) + 1, 1);
strcpy(output, outputString);
*outputv = output;
// We reinitialize the globals on exit out of general paranoia
initglobals();
}
SEXP attribute_hidden do_edit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
int i, rc;
ParseStatus status;
SEXP x, fn, envir, ed, src, srcfile, Rfn;
char *filename, *editcmd;
const char *cmd;
const void *vmaxsave;
FILE *fp;
#ifdef Win32
SEXP ti;
char *title;
#endif
checkArity(op, args);
vmaxsave = vmaxget();
x = CAR(args); args = CDR(args);
if (TYPEOF(x) == CLOSXP) envir = CLOENV(x);
else envir = R_NilValue;
PROTECT(envir);
fn = CAR(args); args = CDR(args);
if (!isString(fn))
error(_("invalid argument to edit()"));
if (LENGTH(STRING_ELT(fn, 0)) > 0) {
const char *ss = translateChar(STRING_ELT(fn, 0));
filename = R_alloc(strlen(ss), sizeof(char));
strcpy(filename, ss);
}
else filename = DefaultFileName;
if (x != R_NilValue) {
if((fp=R_fopen(R_ExpandFileName(filename), "w")) == NULL)
errorcall(call, _("unable to open file"));
if (LENGTH(STRING_ELT(fn, 0)) == 0) EdFileUsed++;
if (TYPEOF(x) != CLOSXP || isNull(src = getAttrib(x, R_SourceSymbol)))
src = deparse1(x, 0, FORSOURCING); /* deparse for sourcing, not for display */
for (i = 0; i < LENGTH(src); i++)
fprintf(fp, "%s\n", translateChar(STRING_ELT(src, i)));
fclose(fp);
}
#ifdef Win32
ti = CAR(args);
#endif
args = CDR(args);
ed = CAR(args);
if (!isString(ed)) errorcall(call, _("argument 'editor' type not valid"));
cmd = translateChar(STRING_ELT(ed, 0));
if (strlen(cmd) == 0) errorcall(call, _("argument 'editor' is not set"));
editcmd = R_alloc(strlen(cmd) + strlen(filename) + 6, sizeof(char));
#ifdef Win32
if (!strcmp(cmd,"internal")) {
if (!isString(ti))
error(_("'title' must be a string"));
if (LENGTH(STRING_ELT(ti, 0)) > 0) {
title = R_alloc(strlen(CHAR(STRING_ELT(ti, 0)))+1, sizeof(char));
strcpy(title, CHAR(STRING_ELT(ti, 0)));
} else {
title = R_alloc(strlen(filename)+1, sizeof(char));
strcpy(title, filename);
}
Rgui_Edit(filename, CE_NATIVE, title, 1);
}
else {
/* Quote path if necessary */
if(cmd[0] != '"' && Rf_strchr(cmd, ' '))
sprintf(editcmd, "\"%s\" \"%s\"", cmd, filename);
else
sprintf(editcmd, "%s \"%s\"", cmd, filename);
rc = runcmd(editcmd, CE_NATIVE, 1, 1, NULL, NULL, NULL);
if (rc == NOLAUNCH)
errorcall(call, _("unable to run editor '%s'"), cmd);
if (rc != 0)
warningcall(call, _("editor ran but returned error status"));
}
#else
if (ptr_R_EditFile)
rc = ptr_R_EditFile(filename);
else {
sprintf(editcmd, "%s %s", cmd, filename);
rc = R_system(editcmd);
}
if (rc != 0)
errorcall(call, _("problem with running editor %s"), cmd);
#endif
if (asLogical(GetOption1(install("keep.source")))) {
PROTECT(Rfn = findFun(install("readLines"), R_BaseEnv));
PROTECT(src = lang2(Rfn, ScalarString(mkChar(R_ExpandFileName(filename)))));
PROTECT(src = eval(src, R_BaseEnv));
PROTECT(Rfn = findFun(install("srcfilecopy"), R_BaseEnv));
PROTECT(srcfile = lang3(Rfn, ScalarString(mkChar("<tmp>")), src));
srcfile = eval(srcfile, R_BaseEnv);
UNPROTECT(5);
} else
srcfile = R_NilValue;
PROTECT(srcfile);
/* <FIXME> setup a context to close the file, and parse and eval
line by line */
if((fp = R_fopen(R_ExpandFileName(filename), "r")) == NULL)
errorcall(call, _("unable to open file to read"));
x = PROTECT(R_ParseFile(fp, -1, &status, srcfile));
fclose(fp);
if (status != PARSE_OK)
errorcall(call,
_("%s occurred on line %d\n use a command like\n x <- edit()\n to recover"), R_ParseErrorMsg, R_ParseError);
R_ResetConsole();
{ /* can't just eval(x) here */
int j, n;
SEXP tmp = R_NilValue;
n = LENGTH(x);
for (j = 0 ; j < n ; j++)
tmp = eval(VECTOR_ELT(x, j), R_GlobalEnv);
x = tmp;
}
if (TYPEOF(x) == CLOSXP && envir != R_NilValue)
SET_CLOENV(x, envir);
UNPROTECT(3);
vmaxset(vmaxsave);
return (x);
}
static void c50(char **namesv,
char **datav,
char **costv,
int *subset,
int *rules,
int *utility,
int *trials,
int *winnow,
double *sample,
int *seed,
int *noGlobalPruning,
double *CF,
int *minCases,
int *fuzzyThreshold,
int *earlyStopping,
char **treev,
char **rulesv,
char **outputv)
{
int val; /* Used by setjmp/longjmp for implementing rbm_exit */
// Announce ourselves for testing
// Rprintf("c50 called\n");
// Initialize the globals to the values that the c50
// program would have at the start of execution
initglobals();
// Set globals based on the arguments. This is analogous
// to parsing the command line in the c50 program.
setglobals(*subset, *rules, *utility, *trials, *winnow, *sample,
*seed, *noGlobalPruning, *CF, *minCases, *fuzzyThreshold,
*earlyStopping, *costv);
// Handles the strbufv data structure
rbm_removeall();
// Deallocates memory allocated by NewCase.
// Not necessary since it's also called at the end of this function,
// but it doesn't hurt, and I'm feeling paranoid.
FreeCases();
// XXX Should this be controlled via an option?
// Rprintf("Calling setOf\n");
setOf();
// Create a strbuf using *namesv as the buffer.
// Note that this is a readonly strbuf since we can't
// extend *namesv.
STRBUF *sb_names = strbuf_create_full(*namesv, strlen(*namesv));
// Register this strbuf using the name "undefined.names"
if (rbm_register(sb_names, "undefined.names", 0) < 0) {
error("undefined.names already exists");
}
// Create a strbuf using *datav and register it as "undefined.data"
STRBUF *sb_datav = strbuf_create_full(*datav, strlen(*datav));
// XXX why is sb_datav copied? was that part of my debugging?
// XXX or is this the cause of the leak?
if (rbm_register(strbuf_copy(sb_datav), "undefined.data", 0) < 0) {
error("undefined data already exists");
}
// Create a strbuf using *costv and register it as "undefined.costs"
if (strlen(*costv) > 0) {
// Rprintf("registering cost matrix: %s", *costv);
STRBUF *sb_costv = strbuf_create_full(*costv, strlen(*costv));
// XXX should sb_costv be copied?
if (rbm_register(sb_costv, "undefined.costs", 0) < 0) {
error("undefined.cost already exists");
}
} else {
// Rprintf("no cost matrix to register\n");
}
/*
* We need to initialize rbm_buf before calling any code that
* might call exit/rbm_exit.
*/
if ((val = setjmp(rbm_buf)) == 0) {
// Real work is done here
// Rprintf("Calling c50main\n");
c50main();
// Rprintf("c50main finished\n");
if (*rules == 0) {
// Get the contents of the the tree file
STRBUF *treebuf = rbm_lookup("undefined.tree");
if (treebuf != NULL) {
char *treeString = strbuf_getall(treebuf);
char *treeObj = R_alloc(strlen(treeString) + 1, 1);
strcpy(treeObj, treeString);
// I think the previous value of *treev will be garbage collected
*treev = treeObj;
} else {
// XXX Should *treev be assigned something in this case?
// XXX Throw an error?
}
} else {
// Get the contents of the the rules file
STRBUF *rulesbuf = rbm_lookup("undefined.rules");
if (rulesbuf != NULL) {
char *rulesString = strbuf_getall(rulesbuf);
char *rulesObj = R_alloc(strlen(rulesString) + 1, 1);
strcpy(rulesObj, rulesString);
// I think the previous value of *rulesv will be garbage collected
*rulesv = rulesObj;
} else {
// XXX Should *rulesv be assigned something in this case?
// XXX Throw an error?
}
}
} else {
Rprintf("c50 code called exit with value %d\n", val - JMP_OFFSET);
}
// Close file object "Of", and return its contents via argument outputv
char *outputString = closeOf();
char *output = R_alloc(strlen(outputString) + 1, 1);
strcpy(output, outputString);
*outputv = output;
// Deallocates memory allocated by NewCase
FreeCases();
// We reinitialize the globals on exit out of general paranoia
initglobals();
}
SEXP Dens_bw(const SEXP data_sxp,
const SEXP cluster_sxp,
const SEXP cluster_center_sxp,
const SEXP stdev_sxp,
const SEXP choosen_metric_sxp)
{
// temporary variables
int i, j, k, pos, protect_num=0;
// some constants
int clust_num, dim_num, obj_num;
double *cluster_center;
int *cluster_tab;
cluster_center = REAL(cluster_center_sxp);
cluster_tab = INTEGER(cluster_sxp);
SEXP data_dim;
PROTECT( data_dim = getAttrib(data_sxp, R_DimSymbol) );
protect_num++;
obj_num = INTEGER(data_dim)[0];
SEXP dim;
PROTECT( dim = getAttrib(cluster_center_sxp, R_DimSymbol) );
protect_num++;
clust_num = INTEGER(dim)[0];
dim_num = INTEGER(dim)[1];
SEXP density_middle_point_sxp;
PROTECT( density_middle_point_sxp = allocMatrix(VECSXP, clust_num, clust_num) );
protect_num++;
SEXP* midp_coords_sxp;
midp_coords_sxp = (SEXP*) R_alloc(clust_num*clust_num, sizeof(SEXP) );
// initilaize matix of vectors, each vector represent density_middle point between two cluter centers
double *tmp_tab;
for(i=0; i<clust_num; i++)
for(j=0; j<clust_num; j++)
{
pos = j + i*clust_num;
if(i<j)
{
PROTECT( midp_coords_sxp[pos] = allocVector(REALSXP, dim_num) );
tmp_tab = REAL(midp_coords_sxp[pos]);
// compute density_middle point between center of cluster i and j
for(k=0; k<dim_num; k++)
tmp_tab[k] = ( cluster_center[i + k*clust_num] + cluster_center[j + k*clust_num] )/2;
}
else PROTECT( midp_coords_sxp[pos] = R_NilValue );
protect_num++;
SET_VECTOR_ELT( density_middle_point_sxp, pos, midp_coords_sxp[pos] );
}
// time to get the pointer to the distance function
double *mean = NULL;
pMetricFunct metric;
metric = getMetricFunct(INTEGER(choosen_metric_sxp)[0]);
if( INTEGER(choosen_metric_sxp)[0] == CORRELATION )
{
SEXP mean_sxp;
PROTECT( mean_sxp = clv_mean(data_sxp, obj_num, dim_num) );
protect_num++;
mean = REAL(mean_sxp);
}
// vector and matrix create to store information about density of clusters
// and "density" of space between centers of clusters
SEXP center_density_sxp, midp_density_sxp;
int *center_density, *midp_density;
double stdev;
PROTECT( center_density_sxp = allocVector(INTSXP, clust_num) );
protect_num++;
PROTECT( midp_density_sxp = allocMatrix(INTSXP, clust_num, clust_num) );
protect_num++;
center_density = INTEGER(center_density_sxp);
midp_density = INTEGER(midp_density_sxp);
stdev = REAL(stdev_sxp)[0];
for(i=0; i<clust_num; i++)
{
center_density[i] = 0;
pos = i*clust_num;
for(j=0; j<clust_num; j++) midp_density[ j + pos ] = 0;
}
// declare return value
SEXP result_sxp;
PROTECT( result_sxp = allocVector(REALSXP, 1) );
protect_num++;
// compute density over clusters centers and density_middle points between cluster centers
int density_center1, density_center2, density_middle;
double dist;
double tmp_sum = 0;
for(i=0; i<clust_num; i++)
for(j=i+1; j<clust_num; j++)
{
density_center1 = density_center2 = density_middle = 0;
for(k=0; k<obj_num; k++)
{
// if current object belongs to cluster i or j
if( cluster_tab[k] == (i+1) || cluster_tab[k] == (j+1) )
{
// check if object "k" belongs to any of the following spheres:
// B( v(i), stdev ), B( v(j), stdev ) or B( u(i,j), stdev )
dist = metric(data_sxp, cluster_center_sxp, k, i, obj_num, clust_num, dim_num, mean);
if( dist <= stdev ) density_center1++;
//Rprintf("Dist from center %d to obejct %d: %f\n", i+1, k+1, dist);
dist = metric(data_sxp, cluster_center_sxp, k, j, obj_num, clust_num, dim_num, mean);
if( dist <= stdev ) density_center2++;
//Rprintf("Dist from center %d to obejct %d: %f\n", j+1, k+1, dist);
pos = j + i*clust_num;
dist = metric(data_sxp, midp_coords_sxp[pos], k, 0, obj_num, 1, dim_num, mean);
if( dist <= stdev ) density_middle++;
//Rprintf("Dist from density_middle (%d,%d) to obejct %d: %f\n", i+1, j+1, k+1, dist);
}
}
// check if Dens_bw index is well defined
if( density_center1 != 0 && density_center2 != 0 )
tmp_sum += density_middle/(1.0*( density_center1 > density_center2 ? density_center1 : density_center2 ));
else
{
// theoretically Dens_bw should be undefined in here
// (division by 0) but we will set it as +Inf
REAL(result_sxp)[0] = R_PosInf;
UNPROTECT(protect_num);
return result_sxp;
}
}
REAL(result_sxp)[0] = (tmp_sum*2.0)/(clust_num*(clust_num-1));
UNPROTECT(protect_num);
return result_sxp;
}
SEXP ffApply(SEXP result, SEXP data, SEXP margin, SEXP function,
SEXP nrows, SEXP ncols, int worldRank,
SEXP out_filename, int worldSize) {
SEXP ans;
int my_start, my_end, N, function_nlines;
int local_check = 0, global_check = 0;
char *filename, *file_out;
int *filesize;
double *mapped_data_matrix;
filesize = (int *) R_alloc(1, sizeof(int));
if(worldRank == MASTER_PROCESS) {
/* data argument is actually a path to a binary file where data is stored */
filename = (char *)CHAR((STRING_ELT(data,0)));
file_out = (char *)CHAR(STRING_ELT(out_filename,0));
/* function SEXP object is a vector of strings, each element contains
a single line of the function definition */
function_nlines = length(function);
} else {
filename = (char *) R_alloc(FILENAME_LENGTH, sizeof(char));
file_out = (char *) R_alloc(FILENAME_LENGTH, sizeof(char));
PROTECT(nrows = allocVector(INTSXP, 1));
PROTECT(ncols = allocVector(INTSXP, 1));
PROTECT(margin = allocVector(INTSXP, 1));
}
MPI_Bcast(filename, FILENAME_LENGTH, MPI_CHAR, 0, MPI_COMM_WORLD);
MPI_Bcast(file_out, FILENAME_LENGTH, MPI_CHAR, 0, MPI_COMM_WORLD);
MPI_Bcast(INTEGER(nrows), 1, MPI_INT, 0, MPI_COMM_WORLD);
MPI_Bcast(INTEGER(ncols), 1, MPI_INT, 0, MPI_COMM_WORLD);
MPI_Bcast(INTEGER(margin), 1, MPI_INT, 0, MPI_COMM_WORLD);
MPI_Bcast(&function_nlines, 1, MPI_INT, 0, MPI_COMM_WORLD);
if(worldRank != MASTER_PROCESS) {
PROTECT(function = allocVector(STRSXP, function_nlines));
}
if((mapped_data_matrix = map_file(filename, filesize)) == NULL) {
local_check = -1;
}
/* Check if all processes have successfully mapped the file to memory */
MPI_Allreduce(&local_check, &global_check, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD);
if ( global_check != 0 ) return ScalarInteger(-1);
/* Matrix dimensions in R are interpreted differently than in C.
We will refer to R rows and columns ordering, so rows are not alligned
in memory */
if (INTEGER(margin)[0] == 1) {
N = INTEGER(nrows)[0];
} else if (INTEGER(margin)[0] == 2) {
N = INTEGER(ncols)[0];
} else {
DEBUG("Do not know how to distribute margin number %d\n",
INTEGER(margin)[0]);
return R_NilValue;
}
loopDistribute(worldRank, worldSize, N, &my_start, &my_end);
/* Bcast function name or definition, cover case when definition is split into
several lines and stored as a SEXP string vector */
bcastRFunction(function, function_nlines, worldRank);
/* Response container, Vector of SEXPs, margin determines vector length */
PROTECT(ans = allocVector(VECSXP, 1));
do_ffApply(ans, mapped_data_matrix, margin, function, my_start, my_end,
INTEGER(nrows)[0], INTEGER(ncols)[0], worldRank, file_out);
if(worldRank != MASTER_PROCESS) {
UNPROTECT(4);
} else {
UNPROTECT(1);
}
return result;
}
/* start of AS 182 */
void
forkal(Starma G, int d, int il, double *delta, double *y, double *amse,
int *ifault)
{
int p = G->p, q = G->q, r = G->r, n = G->n, np = G->np;
double *phi = G->phi, *V = G->V, *w = G->w, *xrow = G->xrow;
double *a, *P, *store;
int rd = r + d, rz = rd*(rd + 1)/2;
double phii, phij, sigma2, a1, aa, dt, phijdt, ams, tmp;
int i, j, k, l, nu = 0;
int k1;
int i45, jj, kk, lk, ll;
int nt;
int kk1, lk1;
int ind, jkl, kkk;
int ind1, ind2;
/* Finite sample prediction from ARIMA processes. */
/* This routine will calculate the finite sample predictions
and their conditional mean square errors for any ARIMA process. */
/* invoking this routine will calculate the finite sample predictions */
/* and their conditional mean square errors for any arima process. */
store = (double *) R_alloc(rd, sizeof(double));
Free(G->a); G->a = a = Calloc(rd, double);
Free(G->P); G->P = P = Calloc(rz, double);
/* check for input faults. */
*ifault = 0;
if (p < 0) *ifault = 1;
if (q < 0) *ifault += 2;
if (p * p + q * q == 0) *ifault = 4;
if (r != max(p, q + 1)) *ifault = 5;
if (np != r * (r + 1) / 2) *ifault = 6;
if (d < 0) *ifault = 8;
if (il < 1) *ifault = 11;
if (*ifault != 0) return;
/* Find initial likelihood conditions. */
if (r == 1) {
a[0] = 0.0;
V[0] = 1.0;
P[0] = 1.0 / (1.0 - phi[0] * phi[0]);
} else starma(G, ifault);
/* Calculate data transformations */
nt = n - d;
if (d > 0) {
for (j = 0; j < d; j++) {
store[j] = w[n - j - 2];
if(ISNAN(store[j]))
error(_("missing value in last %d observations"), d);
}
for (i = 0; i < nt; i++) {
aa = 0.0;
for (k = 0; k < d; ++k) aa -= delta[k] * w[d + i - k - 1];
w[i] = w[i + d] + aa;
}
}
/* Evaluate likelihood to obtain final Kalman filter conditions */
{
double sumlog = 0.0, ssq = 0.0;
int nit = 0;
G->n = nt;
karma(G, &sumlog, &ssq, 1, &nit);
}
/* Calculate m.l.e. of sigma squared */
sigma2 = 0.0;
for (j = 0; j < nt; j++) {
/* MacOS X/gcc 3.5 does/didn't have isnan defined properly */
tmp = G->resid[j];
if(!ISNAN(tmp)) { nu++; sigma2 += tmp * tmp; }
}
sigma2 /= nu;
/* reset the initial a and P when differencing occurs */
if (d > 0) {
for (i = 0; i < np; i++) xrow[i] = P[i];
for (i = 0; i < rz; i++) P[i] = 0.0;
ind = 0;
for (j = 0; j < r; j++) {
k = j * (rd + 1) - j * (j + 1) / 2;
for (i = j; i < r; i++) P[k++] = xrow[ind++];
}
for (j = 0; j < d; j++) a[r + j] = store[j];
}
i45 = 2*rd + 1;
jkl = r * (2*d + r + 1) / 2;
for (l = 0; l < il; ++l) {
/* predict a */
a1 = a[0];
for (i = 0; i < r - 1; i++) a[i] = a[i + 1];
a[r - 1] = 0.0;
for (j = 0; j < p; j++) a[j] += phi[j] * a1;
if (d > 0) {
for (j = 0; j < d; j++) a1 += delta[j] * a[r + j];
for (i = rd - 1; i > r; i--) a[i] = a[i - 1];
a[r] = a1;
}
/* predict P */
if (d > 0) {
for (i = 0; i < d; i++) {
store[i] = 0.0;
for (j = 0; j < d; j++) {
ll = max(i, j);
k = min(i, j);
jj = jkl + (ll - k) + k * (2*d + 2 - k - 1) / 2;
store[i] += delta[j] * P[jj];
}
}
if (d > 1) {
for (j = 0; j < d - 1; j++) {
jj = d - j - 1;
lk = (jj - 1) * (2*d + 2 - jj) / 2 + jkl;
lk1 = jj * (2*d + 1 - jj) / 2 + jkl;
for (i = 0; i <= j; i++) P[lk1++] = P[lk++];
}
for (j = 0; j < d - 1; j++)
P[jkl + j + 1] = store[j] + P[r + j];
}
P[jkl] = P[0];
for (i = 0; i < d; i++)
P[jkl] += delta[i] * (store[i] + 2.0 * P[r + i]);
for (i = 0; i < d; i++) store[i] = P[r + i];
for (j = 0; j < r; j++) {
kk1 = (j+1) * (2*rd - j - 2) / 2 + r;
k1 = j * (2*rd - j - 1) / 2 + r;
for (i = 0; i < d; i++) {
kk = kk1 + i;
k = k1 + i;
P[k] = phi[j] * store[i];
if (j < r - 1) P[k] += P[kk];
}
}
for (j = 0; j < r; j++) {
store[j] = 0.0;
kkk = (j + 1) * (i45 - j - 1) / 2 - d;
for (i = 0; i < d; i++) store[j] += delta[i] * P[kkk++];
}
for (j = 0; j < r; j++) {
k = (j + 1) * (rd + 1) - (j + 1) * (j + 2) / 2;
for (i = 0; i < d - 1; i++) {
--k;
P[k] = P[k - 1];
}
}
for (j = 0; j < r; j++) {
k = j * (2*rd - j - 1) / 2 + r;
P[k] = store[j] + phi[j] * P[0];
if (j < r - 1) P[k] += P[j + 1];
}
}
for (i = 0; i < r; i++) store[i] = P[i];
ind = 0;
dt = P[0];
for (j = 0; j < r; j++) {
phij = phi[j];
phijdt = phij * dt;
ind2 = j * (2*rd - j + 1) / 2 - 1;
ind1 = (j + 1) * (i45 - j - 1) / 2 - 1;
for (i = j; i < r; i++) {
++ind2;
phii = phi[i];
P[ind2] = V[ind++] + phii * phijdt;
if (j < r - 1) P[ind2] += store[j + 1] * phii;
if (i < r - 1)
P[ind2] += store[i + 1] * phij + P[++ind1];
}
}
/* predict y */
y[l] = a[0];
for (j = 0; j < d; j++) y[l] += a[r + j] * delta[j];
/* calculate m.s.e. of y */
ams = P[0];
if (d > 0) {
for (j = 0; j < d; j++) {
k = r * (i45 - r) / 2 + j * (2*d + 1 - j) / 2;
tmp = delta[j];
ams += 2.0 * tmp * P[r + j] + P[k] * tmp * tmp;
}
for (j = 0; j < d - 1; j++) {
k = r * (i45 - r) / 2 + 1 + j * (2*d + 1 - j) / 2;
for (i = j + 1; i < d; i++)
ams += 2.0 * delta[i] * delta[j] * P[k++];
}
}
amse[l] = ams * sigma2;
}
return;
}
void CRF::TreeBP(bool maximize)
{
messages = (double ***) R_allocArray<double>(2, nEdges, maxState);
for (int i = 0; i < nEdges; i++)
for (int j = 0; j < maxState; j++)
messages[0][i][j] = messages[1][i][j] = 1;
int *nWaiting = (int *) R_alloc(nNodes, sizeof(int));
int **waiting = (int **) R_allocArray2<int>(nNodes, nAdj);
int *sent = (int *) R_alloc(nNodes, sizeof(int));
int senderHead, senderTail, nReceiver;
int *sender = (int *) R_alloc(nNodes * 2, sizeof(int));
int *receiver = (int *) R_alloc(nNodes, sizeof(int));
double sumBel;
senderHead = senderTail = nReceiver = 0;
for (int i = 0; i < nNodes; i++)
{
nWaiting[i] = nAdj[i];
for (int j = 0; j < nAdj[i]; j++)
waiting[i][j] = 1;
sent[i] = -1;
if (nAdj[i] == 1)
sender[senderTail++] = i;
sumBel = 0;
for (int j = 0; j < nStates[i]; j++)
sumBel += NodeBel(i, j) = NodePot(i, j);
for (int j = 0; j < nStates[i]; j++)
NodeBel(i, j) /= sumBel;
}
int s, r, e, n;
double *msg;
double *outgoing = (double *) R_alloc(maxState, sizeof(double));
while (senderHead < senderTail)
{
R_CheckUserInterrupt();
s = sender[senderHead++];
if (sent[s] == -2) continue;
nReceiver = 0;
if (nWaiting[s] == 1)
{
for (int i = 0; i < nAdj[s]; i++)
{
if (waiting[s][i])
{
receiver[nReceiver++] = i;
sent[s] = nAdj[s] == 1 ? -2 : i;
break;
}
}
}
else
{
for (int i = 0; i < nAdj[s]; i++)
if (sent[s] != i)
receiver[nReceiver++] = i;
sent[s] = -2;
}
/* send messages */
for (int i = 0; i < nReceiver; i++)
{
n = receiver[i];
r = AdjNodes(s, n);
e = AdjEdges(s, n);
for (int j = 0; j < nAdj[r]; j++)
if (AdjNodes(r, j) == s)
{
waiting[r][j] = 0;
nWaiting[r]--;
break;
}
if (sent[r] != -2 && nWaiting[r] <= 1)
sender[senderTail++] = r;
if (maximize)
msg = ComputeMessagesMax(s, r, e, outgoing, messages, messages);
else
msg = ComputeMessagesSum(s, r, e, outgoing, messages, messages);
sumBel = 0;
for (int j = 0; j < nStates[r]; j++)
sumBel += NodeBel(r, j) *= msg[j];
for (int j = 0; j < nStates[r]; j++)
NodeBel(r, j) /= sumBel;
}
}
}
SEXP freadR(
// params passed to freadMain
SEXP inputArg,
SEXP sepArg,
SEXP decArg,
SEXP quoteArg,
SEXP headerArg,
SEXP nrowLimitArg,
SEXP skipArg,
SEXP NAstringsArg,
SEXP stripWhiteArg,
SEXP skipEmptyLinesArg,
SEXP fillArg,
SEXP showProgressArg,
SEXP nThreadArg,
SEXP verboseArg,
SEXP warnings2errorsArg,
SEXP logical01Arg,
// extras needed by callbacks from freadMain
SEXP selectArg,
SEXP dropArg,
SEXP colClassesArg,
SEXP integer64Arg,
SEXP encodingArg
) {
verbose = LOGICAL(verboseArg)[0];
warningsAreErrors = LOGICAL(warnings2errorsArg)[0];
freadMainArgs args;
ncol = 0;
dtnrows = 0;
const char *ch, *ch2;
if (!isString(inputArg) || LENGTH(inputArg)!=1)
error("fread input must be a single character string: a filename or the data itself");
ch = ch2 = (const char *)CHAR(STRING_ELT(inputArg,0));
while (*ch2!='\n' && *ch2!='\r' && *ch2!='\0') ch2++;
args.input = (*ch2=='\0') ? R_ExpandFileName(ch) : ch; // for convenience so user doesn't have to call path.expand()
ch = args.input;
while (*ch!='\0' && *ch!='\n' && *ch!='\r') ch++;
if (*ch!='\0' || args.input[0]=='\0') {
if (verbose) DTPRINT("Input contains a \\n or is \"\". Taking this to be text input (not a filename)\n");
args.filename = NULL;
} else {
if (verbose) DTPRINT("Input contains no \\n. Taking this to be a filename to open\n");
args.filename = args.input;
args.input = NULL;
}
if (!isString(sepArg) || LENGTH(sepArg)!=1 || strlen(CHAR(STRING_ELT(sepArg,0)))>1)
error("CfreadR: sep must be 'auto' or a single character ('\\n' is an acceptable single character)");
args.sep = CHAR(STRING_ELT(sepArg,0))[0]; // '\0' when default "auto" was replaced by "" at R level
if (!(isString(decArg) && LENGTH(decArg)==1 && strlen(CHAR(STRING_ELT(decArg,0)))==1))
error("CfreadR: dec must be a single character such as '.' or ','");
args.dec = CHAR(STRING_ELT(decArg,0))[0];
if (!isString(quoteArg) || LENGTH(quoteArg)!=1 || strlen(CHAR(STRING_ELT(quoteArg,0))) > 1)
error("CfreadR: quote must be a single character or empty \"\"");
args.quote = CHAR(STRING_ELT(quoteArg,0))[0];
// header is the only boolean where NA is valid and means 'auto'.
// LOGICAL in R is signed 32 bits with NA_LOGICAL==INT_MIN, currently.
args.header = false;
if (LOGICAL(headerArg)[0]==NA_LOGICAL) args.header = NA_BOOL8;
else if (LOGICAL(headerArg)[0]==TRUE) args.header = true;
args.nrowLimit = INT64_MAX;
// checked at R level
if (isReal(nrowLimitArg)) {
if (R_FINITE(REAL(nrowLimitArg)[0]) && REAL(nrowLimitArg)[0]>=0.0) args.nrowLimit = (int64_t)(REAL(nrowLimitArg)[0]);
} else {
if (INTEGER(nrowLimitArg)[0]>=1) args.nrowLimit = (int64_t)INTEGER(nrowLimitArg)[0];
}
args.logical01 = LOGICAL(logical01Arg)[0];
args.skipNrow=-1;
args.skipString=NULL;
if (isString(skipArg)) {
args.skipString = CHAR(STRING_ELT(skipArg,0)); // LENGTH==1 was checked at R level
} else if (isInteger(skipArg)) {
args.skipNrow = (int64_t)INTEGER(skipArg)[0];
} else error("Internal error: skip not integer or string in freadR.c"); // # nocov
if (!isNull(NAstringsArg) && !isString(NAstringsArg))
error("'na.strings' is type '%s'. Must be either NULL or a character vector.", type2char(TYPEOF(NAstringsArg)));
int nnas = length(NAstringsArg);
const char **NAstrings = (const char **)R_alloc((nnas + 1), sizeof(char*)); // +1 for the final NULL to save a separate nna variable
for (int i=0; i<nnas; i++)
NAstrings[i] = CHAR(STRING_ELT(NAstringsArg,i));
NAstrings[nnas] = NULL;
args.NAstrings = NAstrings;
// here we use _Bool and rely on fread at R level to check these do not contain NA_LOGICAL
args.stripWhite = LOGICAL(stripWhiteArg)[0];
args.skipEmptyLines = LOGICAL(skipEmptyLinesArg)[0];
args.fill = LOGICAL(fillArg)[0];
args.showProgress = LOGICAL(showProgressArg)[0];
if (INTEGER(nThreadArg)[0]<1) error("nThread(%d)<1", INTEGER(nThreadArg)[0]);
args.nth = (uint32_t)INTEGER(nThreadArg)[0];
args.verbose = verbose;
args.warningsAreErrors = warningsAreErrors;
// === extras used for callbacks ===
if (!isString(integer64Arg) || LENGTH(integer64Arg)!=1) error("'integer64' must be a single character string");
const char *tt = CHAR(STRING_ELT(integer64Arg,0));
if (strcmp(tt, "integer64")==0) {
readInt64As = CT_INT64;
} else if (strcmp(tt, "character")==0) {
readInt64As = CT_STRING;
} else if (strcmp(tt,"double")==0 || strcmp(tt,"numeric")==0) {
readInt64As = CT_FLOAT64;
} else STOP("Invalid value integer64='%s'. Must be 'integer64', 'character', 'double' or 'numeric'", tt);
colClassesSxp = colClassesArg; // checked inside userOverride where it is used.
if (!isNull(selectArg) && !isNull(dropArg)) STOP("Use either select= or drop= but not both.");
selectSxp = selectArg;
dropSxp = dropArg;
// Encoding, #563: Borrowed from do_setencoding from base R
// https://github.com/wch/r-source/blob/ca5348f0b5e3f3c2b24851d7aff02de5217465eb/src/main/util.c#L1115
// Check for mkCharLenCE function to locate as to where where this is implemented.
tt = CHAR(STRING_ELT(encodingArg, 0));
if (strcmp(tt, "unknown")==0) ienc = CE_NATIVE;
else if (strcmp(tt, "Latin-1")==0) ienc = CE_LATIN1;
else if (strcmp(tt, "UTF-8")==0) ienc = CE_UTF8;
else STOP("encoding='%s' invalid. Must be 'unknown', 'Latin-1' or 'UTF-8'", tt);
// === end extras ===
RCHK = PROTECT(allocVector(VECSXP, 2));
// see kalibera/rchk#9 and Rdatatable/data.table#2865. To avoid rchk false positives.
// allocateDT() assigns DT to position 0. userOverride() assigns colNamesSxp to position 1; colNamesSxp is used in allocateDT()
freadMain(args);
UNPROTECT(1);
return DT;
}
SEXP
do_lzDecompress (SEXP FROM)
{
SEXP ANS;
LZ4F_decompressionContext_t ctx;
LZ4F_frameInfo_t info;
char *from;
char *ans;
void *src;
size_t m, n, output_size, input_size = xlength(FROM);
size_t ibuf, obuf, icum, ocum;
if(TYPEOF(FROM) != RAWSXP) error("'from' must be raw or character");
from = (char *)RAW(FROM);
/* An implementation following the standard API would do this:
* LZ4F_errorCode_t err = LZ4F_createDecompressionContext(&ctx, LZ4F_VERSION);
* if (LZ4F_isError (err)) error("could not create LZ4 decompression context");
* ...
* LZ4F_freeDecompressionContext(ctx);
* The problem with that approach is that LZ4F_createDecompressionContext
* allocates memory with calloc internally. Later, if R's allocVector fails,
* for example, or if R interrupts this function somewhere in '...' then
* those internal allocations in LZ4F_createDecompressionContext leak--that is
* they aren't ever de-allocated.
*
* We explicitly allocat the LZ4F_decompressionContext_t pointer using a
* replica of the internal LZ4F_dctx_t structure defined near the top of this
* file, see the note and corresponding warning! We allocate on the heap (via
* R_alloc) here instead of a seemingly simpler stack allocation because LZ4
* indicates that the address needs to be aligned to 8-byte boundaries which is
* provided by R_alloc, see:
* https://cran.r-project.org/doc/manuals/r-release/R-exts.html#Transient-storage-allocation
*/
LZ4F_dctx_t *dctxPtr = (LZ4F_dctx_t *)R_alloc(1, sizeof(LZ4F_dctx_t));
memset(dctxPtr, 0, sizeof(LZ4F_dctx_t));
dctxPtr->version = LZ4F_VERSION;
ctx = (LZ4F_decompressionContext_t)dctxPtr;
m = input_size;
n = LZ4F_getFrameInfo(ctx, &info, (void *)from, &input_size);
if (LZ4F_isError (n)) error("LZ4F_getFrameInfo");
src = from + input_size; // lz4 frame header offset
output_size = (size_t) info.contentSize;
ANS = allocVector(RAWSXP, output_size);
ans = (char *)RAW(ANS);
input_size = m - input_size;
icum = 0;
ibuf = lzframe_chunksize;
if(ibuf > input_size) ibuf = input_size;
ocum = 0;
obuf = output_size;
for(;;)
{
n = LZ4F_decompress(ctx, ans, &obuf, src, &ibuf, NULL);
if (LZ4F_isError (n)) error("LZ4F_decompress");
icum = icum + ibuf;
ocum = ocum + obuf;
if(icum >= input_size) break;
ans = ans + obuf;
src = src + ibuf;
ibuf = lzframe_chunksize;
if(ibuf > (input_size - icum)) ibuf = input_size - icum;
obuf = output_size - ocum;
}
return ANS;
}
static SEXP ArraySubset(SEXP x, SEXP s, SEXP call, int drop)
{
int k, mode;
SEXP dimnames, dimnamesnames, p, q, r, result, xdims;
const void *vmaxsave = vmaxget();
mode = TYPEOF(x);
xdims = getAttrib(x, R_DimSymbol);
k = length(xdims);
/* k is now the number of dims */
int **subs = (int**)R_alloc(k, sizeof(int*));
int *indx = (int*)R_alloc(k, sizeof(int));
int *bound = (int*)R_alloc(k, sizeof(int));
R_xlen_t *offset = (R_xlen_t*)R_alloc(k, sizeof(R_xlen_t));
/* Construct a vector to contain the returned values. */
/* Store its extents. */
R_xlen_t n = 1;
r = s;
for (int i = 0; i < k; i++) {
SETCAR(r, int_arraySubscript(i, CAR(r), xdims, x, call));
bound[i] = LENGTH(CAR(r));
n *= bound[i];
r = CDR(r);
}
PROTECT(result = allocVector(mode, n));
r = s;
for (int i = 0; i < k; i++) {
indx[i] = 0;
subs[i] = INTEGER(CAR(r));
r = CDR(r);
}
offset[0] = 1;
for (int i = 1; i < k; i++)
offset[i] = offset[i - 1] * INTEGER(xdims)[i - 1];
/* Transfer the subset elements from "x" to "a". */
for (R_xlen_t i = 0; i < n; i++) {
R_xlen_t ii = 0;
for (int j = 0; j < k; j++) {
int jj = subs[j][indx[j]];
if (jj == NA_INTEGER) {
ii = NA_INTEGER;
goto assignLoop;
}
if (jj < 1 || jj > INTEGER(xdims)[j])
errorcall(call, R_MSG_subs_o_b);
ii += (jj - 1) * offset[j];
}
assignLoop:
switch (mode) {
case LGLSXP:
if (ii != NA_INTEGER)
LOGICAL(result)[i] = LOGICAL(x)[ii];
else
LOGICAL(result)[i] = NA_LOGICAL;
break;
case INTSXP:
if (ii != NA_INTEGER)
INTEGER(result)[i] = INTEGER(x)[ii];
else
INTEGER(result)[i] = NA_INTEGER;
break;
case REALSXP:
if (ii != NA_INTEGER)
REAL(result)[i] = REAL(x)[ii];
else
REAL(result)[i] = NA_REAL;
break;
case CPLXSXP:
if (ii != NA_INTEGER) {
COMPLEX(result)[i] = COMPLEX(x)[ii];
}
else {
COMPLEX(result)[i].r = NA_REAL;
COMPLEX(result)[i].i = NA_REAL;
}
break;
case STRSXP:
if (ii != NA_INTEGER)
SET_STRING_ELT(result, i, STRING_ELT(x, ii));
else
SET_STRING_ELT(result, i, NA_STRING);
break;
case VECSXP:
if (ii != NA_INTEGER)
SET_VECTOR_ELT(result, i, VECTOR_ELT_FIX_NAMED(x, ii));
else
SET_VECTOR_ELT(result, i, R_NilValue);
break;
case RAWSXP:
if (ii != NA_INTEGER)
RAW(result)[i] = RAW(x)[ii];
else
RAW(result)[i] = (Rbyte) 0;
break;
default:
errorcall(call, _("array subscripting not handled for this type"));
break;
}
if (n > 1) {
int j = 0;
while (++indx[j] >= bound[j]) {
indx[j] = 0;
j = (j + 1) % k;
}
}
}
PROTECT(xdims = allocVector(INTSXP, k));
for(int i = 0 ; i < k ; i++)
INTEGER(xdims)[i] = bound[i];
setAttrib(result, R_DimSymbol, xdims);
UNPROTECT(1); /* xdims */
/* The array elements have been transferred. */
/* Now we need to transfer the attributes. */
/* Most importantly, we need to subset the */
/* dimnames of the returned value. */
dimnames = getAttrib(x, R_DimNamesSymbol);
PROTECT(dimnamesnames = getAttrib(dimnames, R_NamesSymbol));
if (dimnames != R_NilValue) {
int j = 0;
PROTECT(xdims = allocVector(VECSXP, k));
if (TYPEOF(dimnames) == VECSXP) {
r = s;
for (int i = 0; i < k ; i++) {
if (bound[i] > 0) {
SET_VECTOR_ELT(xdims, j++,
ExtractSubset(VECTOR_ELT(dimnames, i),
allocVector(STRSXP, bound[i]),
CAR(r), call));
} else { /* 0-length dims have NULL dimnames */
SET_VECTOR_ELT(xdims, j++, R_NilValue);
}
r = CDR(r);
}
}
else {
p = dimnames;
q = xdims;
r = s;
for(int i = 0 ; i < k; i++) {
SETCAR(q, allocVector(STRSXP, bound[i]));
SETCAR(q, ExtractSubset(CAR(p), CAR(q), CAR(r), call));
p = CDR(p);
q = CDR(q);
r = CDR(r);
}
}
setAttrib(xdims, R_NamesSymbol, dimnamesnames);
setAttrib(result, R_DimNamesSymbol, xdims);
UNPROTECT(1); /* xdims */
}
/* This was removed for matrices in 1998
copyMostAttrib(x, result); */
/* Free temporary memory */
vmaxset(vmaxsave);
if (drop)
DropDims(result);
UNPROTECT(2); /* dimnamesnames, result */
return result;
}
/**
* Fit Log-Linear Model to observed contingency table y.
* @param y Observed contingencies. Array of size J.
* @param s Scatter matrix. s[i] is the cell in the observed array that
* corresponds to cell i in the full array. Array of size I.
* @param C Design matrix. Array of size I*(K+1), of which the actual matrix
* takes up I*K cells while the last I are needed for normalization.
* @param maxit Maximum number of iterations.
* @param tol Convergence parameter.
* @param E Full contingency table. Should be initialized with either ones or
* a priori estimates. Array of size I
* @param I Number of cells in the full table.
* @param J Number of cells in the observed table.
* @param K Number of columns in the design matrix.
* @param dec_int_tol Chooses convergence parameter for inner loop (IPF
* algorithm). If value is 0, tol is used, otherwise a decreasing value:
* max(tol,1/(number of iterations)^2).
* @param std_min_C currently not used
* @return Fitted full contingency table in E.
*/
void mygllm (int * y, int * s, double * C, int * maxit, double * tol, double * E,
int * I, int * J, int * K, int * dec_int_tol, int * std_min_C)
{
/* Zählvariablen */
unsigned int i;
unsigned int j;
/* Speicherplatz */
double * X = (double *) R_alloc(*I, sizeof(double));
double * E_alt = (double *) R_alloc(*I, sizeof(double));
/* initialisiert geschätzte beobachtete Werte auf 0 */
double * F= (double *) R_alloc(*J,sizeof(double));
/* Zwischenspeicher für F */
double * F_alt= (double *) R_alloc(*J,sizeof(double));
for (j=0;j<*J;j++)
F_alt[j]=0;
/* Designmatrix normalisieren */
/* Minimum bestimmen */
if (*std_min_C)
{
double min_C=*C;
for (i=1; i< *I * *K; i++)
if (C[i] < min_C)
min_C=C[i];
// printf("Minimum in C:%f",min_C);
/* normalisieren, so dass min(C)==0 */
if (min_C!=0)
for (i=0; i< *I * *K; i++)
C[i]-=min_C;
}
/* maximale Zeilensumme bestimmen */
double max_sum=0;
double sum;
double * sums;
sums = (double *) R_alloc(*I,sizeof(double));
for (i=0; i<*I; i++)
{
sum=0;
for (j=0; j<*K; j++)
sum+=C[i+j* *I]; // Indizierung: Zeile + Spalte * Zeilenanzahl
sums[i]=sum; // Jede Zeilensumme speichern, wird noch benötigt
if (sum > max_sum)
max_sum=sum;
}
/* Normierung: Teilen durch maximale Zeilensumme */
if (max_sum!=1)
for (i=0; i<*I * *K; i++)
C[i]/=max_sum; // Indizierung: Zeile + Spalte * Zeilenanzahl
/* Normierung: Alle Zeilensummen auf 1 */
j=*I * *K; // Anfangsindex der letzten Spalte
for (i=0;i<*I;i++)
{
C[j+i]=1-sums[i]/max_sum; // vorher erfolgte Normierung wird eingerechnet
}
int KK = *K+1;
// print2Ddoublearray(C,*I,KK);
// printf("\n");
/* nach der Normierung Speicherplatz reservieren */
double * Z = (double *) R_alloc(KK,sizeof(double));
double * G = (double *) R_alloc(KK,sizeof(double));
/* eigentlicher Algorithmus beginnt hier */
int it = 0; // Zählt Anzahl der Iterationen
while (it<*maxit)
{
it++;
//Rprintf("Iteration %d\n", it);
/* Aufsummieren der geschätzten beobachtbaren Häufigkeiten in F */
for (i=0; i<*J; i++)
F[i]=0.0;
for (i=0; i<*I; i++)
F[s[i]]+=E[i];
/* Konvergenzkriterium überprüfen */
int break_flag = 1;
for (i=0; i<*J; i++)
{
if (fabs(F[i]-F_alt[i]) > *tol)
{
break_flag=0;
break;
}
}
if (break_flag)
break;
/* Zwischenspeichern der alten Werte in F */
for (i=0; i<*J; i++)
F_alt[i]=F[i];
/* x_i=(e_i * y_ji)/f_ji */
for (i=0;i<*I;i++)
{
if (F[s[i]]!=0)
X[i]=E[i] * y[s[i]] / F[s[i]];
}
/* z_k=... */
int k;
for (k=0;k<KK;k++)
{
Z[k]=0;
for (i=0;i<*I;i++)
Z[k]+=C[i+k * *I]*X[i];
}
double int_tol;
if (*dec_int_tol)
{
int_tol=1/((double)it * (double)it);
if (int_tol<*tol)
int_tol=*tol;
}
else
int_tol=*tol;
do
{
for (i=0;i<*I;i++)
E_alt[i]=E[i];
for (k=0;k<KK;k++)
{
G[k]=0;
for (i=0;i<*I;i++)
G[k]+=C[i+k * *I] * E[i];
/* e_i^*=... */
for (i=0;i<*I;i++)
if (G[k]!=0 && C[i+k * *I]!=0)
E[i]*=pow(Z[k]/G[k],C[i+k * *I]);
}
/* Konvergenzkriterium überprüfen */
break_flag=0;
for (i=0;i<*I;i++)
{
if (fabs(E[i]-E_alt[i]) > int_tol)
{
break_flag=1;
break;
}
}
} while (break_flag);
}
}
void est_map_f2i(int n_ind, int n_mar, int *geno, double *d,
int m, double p, double error_prob,
double *loglik, int maxit, double tol, int verbose)
{
int i, j, j2, v, v2, it, flag=0, **Geno, n_states, n_bcstates;
double s, **alpha, **beta, **gamma, *cur_d, *rf;
double ***tm, *temp;
double curloglik;
double initprob;
n_bcstates = 2*(m+1);
n_states = n_bcstates*n_bcstates;
initprob = -log((double)n_states);
/* allocate space for beta and reorganize geno */
reorg_geno(n_ind, n_mar, geno, &Geno);
allocate_alpha(n_mar, n_states, &alpha);
allocate_alpha(n_mar, n_states, &beta);
allocate_dmatrix(n_states, n_states, &gamma);
allocate_double(n_mar-1, &cur_d);
allocate_double(n_mar-1, &rf);
/* allocate space for the [backcross] transition matrices */
/* size n_states x n_states x (n_mar-1) */
/* tm[state1][state2][interval] */
tm = (double ***)R_alloc(n_bcstates, sizeof(double **));
tm[0] = (double **)R_alloc(n_bcstates * n_bcstates, sizeof(double *));
for(i=1; i<n_bcstates; i++) tm[i] = tm[i-1] + n_bcstates;
tm[0][0] = (double *)R_alloc(n_bcstates * n_bcstates * (n_mar - 1),
sizeof(double));
temp = tm[0][0];
for(i=0; i < n_bcstates; i++) {
for(j=0; j < n_bcstates; j++) {
tm[i][j] = temp;
temp += n_mar-1;
}
}
if(verbose) {
/* print initial estimates */
Rprintf(" ");
for(j=0; j<n_mar-1; j++) Rprintf("%.3lf ", d[j]);
Rprintf("\n");
}
for(j=0; j<n_mar-1; j++) d[j] /= 100.0; /* convert to Morgans */
/* begin EM algorithm */
for(it=0; it<maxit; it++) {
for(j=0; j<n_mar-1; j++) {
cur_d[j] = d[j];
rf[j] = 0.0;
}
/* calculate the transition matrices [for BC] */
step_bci(n_mar, n_bcstates, tm, cur_d, m, p, maxit, tol);
for(i=0; i<n_ind; i++) { /* i = individual */
R_CheckUserInterrupt(); /* check for ^C */
/* initialize alpha and beta */
for(v=0; v<n_states; v++) {
alpha[v][0] = initprob + emit_f2i(Geno[0][i], v, error_prob, m, n_bcstates);
beta[v][n_mar-1] = 0.0;
}
/* forward-backward equations */
for(j=1,j2=n_mar-2; j<n_mar; j++, j2--) {
for(v=0; v<n_states; v++) {
alpha[v][j] = alpha[0][j-1] + step_f2i(0, v, j-1, tm, n_bcstates);
beta[v][j2] = beta[0][j2+1] + step_f2i(v, 0, j2, tm, n_bcstates) +
emit_f2i(Geno[j2+1][i], 0, error_prob, m, n_bcstates);
for(v2=1; v2<n_states; v2++) {
alpha[v][j] = addlog(alpha[v][j], alpha[v2][j-1] +
step_f2i(v2, v, j-1, tm, n_bcstates));
beta[v][j2] = addlog(beta[v][j2], beta[v2][j2+1] +
step_f2i(v, v2, j2, tm, n_bcstates) +
emit_f2i(Geno[j2+1][i], v2, error_prob, m, n_bcstates));
}
alpha[v][j] += emit_f2i(Geno[j][i], v, error_prob, m, n_bcstates);
}
}
for(j=0; j<n_mar-1; j++) {
/* calculate gamma = log Pr(v1, v2, O) */
for(v=0, s=0.0; v<n_states; v++) {
for(v2=0; v2<n_states; v2++) {
gamma[v][v2] = alpha[v][j] + beta[v2][j+1] +
emit_f2i(Geno[j+1][i], v2, error_prob, m, n_bcstates) +
step_f2i(v, v2, j, tm, n_bcstates);
if(v==0 && v2==0) s = gamma[v][v2];
else s = addlog(s, gamma[v][v2]);
}
}
for(v=0; v<n_states; v++) {
for(v2=0; v2<n_states; v2++) {
rf[j] += nrec_f2i(v, v2, m, n_bcstates) * exp(gamma[v][v2] - s);
}
}
}
} /* loop over individuals */
/* rescale */
for(j=0; j<n_mar-1; j++) {
rf[j] /= (double)n_ind;
/*
if(rf[j] < tol/100.0) rf[j] = tol/100.0;
else if(rf[j] > 0.5-tol/100.0) rf[j] = 0.5-tol/100.0;
*/
}
/* use map function to convert back to distances */
for(j=0; j<n_mar-1; j++)
d[j] = imf_stahl(rf[j], m, p, 1e-10, 1000);
if(verbose > 1) { /* print some debugging stuff */
if(verbose == 2) Rprintf("Iteration");
Rprintf(" %4d ", it+1);
if(verbose > 2)
for(j=0; j<n_mar-1; j++) Rprintf("%.3lf ", d[j]*100.0);
Rprintf("\n");
}
/* check convergence */
for(j=0, flag=0; j<n_mar-1; j++) {
if(fabs(d[j] - cur_d[j]) > tol*(cur_d[j]+tol*100.0)) {
flag = 1;
break;
}
}
if(!flag) break;
} /* end EM algorithm */
if(flag) warning("Didn't converge!\n");
/* re-calculate transition matrices */
step_bci(n_mar, n_bcstates, tm, d, m, p, maxit, tol);
/* calculate log likelihood */
*loglik = 0.0;
for(i=0; i<n_ind; i++) { /* i = individual */
/* initialize alpha */
for(v=0; v<n_states; v++)
alpha[v][0] = initprob + emit_f2i(Geno[0][i], v, error_prob, m, n_bcstates);
/* forward equations */
for(j=1; j<n_mar; j++) {
for(v=0; v<n_states; v++) {
alpha[v][j] = alpha[0][j-1] + step_f2i(0, v, j-1, tm, n_bcstates);
for(v2=1; v2<n_states; v2++)
alpha[v][j] = addlog(alpha[v][j], alpha[v2][j-1] +
step_f2i(v2, v, j-1, tm, n_bcstates));
alpha[v][j] += emit_f2i(Geno[j][i], v, error_prob, m, n_bcstates);
}
}
curloglik = alpha[0][n_mar-1];
for(v=1; v<n_states; v++)
curloglik = addlog(curloglik, alpha[v][n_mar-1]);
*loglik += curloglik;
}
/* convert distances back to cM */
for(j=0; j<n_mar-1; j++) d[j] *= 100.0;
if(verbose) {
/* print final estimates */
Rprintf(" %4d ", it+1);
for(j=0; j<n_mar-1; j++) Rprintf("%.3lf ", d[j]);
Rprintf("\n");
Rprintf("loglik: %10.4lf\n\n", *loglik);
}
}
void twosample_incidence_ks(int *event, int *group, int *n, int *nsim,
double *f11, double *f12, double *f21, double *f22, double *test_process,
double *stat, double *pval_sim, double *test_process_plot_sim, int *nsim_plot)
{
GetRNGstate();
int i,j,n1,n2;
double temp;
int *y1,*y2;
y1 = (int *) R_alloc(2**n,sizeof(int));
y2 = y1 + *n;
double *s1,*s2,*test_process_sim,*g,*f01;
s1 = (double *) R_alloc(5**n,sizeof(double));
s2 = s1 + *n;
test_process_sim = s2 + *n;
g = test_process_sim + *n;
f01 = g + *n;
double stat_sim;
/* OBSERVED test statistic */
twosample_incidence_ks_process(event, group, n, y1, y2, f11, f12, f21, f22,
s1, s2, test_process);
*stat = ks_stat_cum(test_process, n);
n1 = y1[0];
n2 = y2[0];
/* null (pooled sample) estimator of the cause 1 cif */
twosample_incidence_f01(event, y1, y2, s1, s2, f01, n);
/* LWY SIMULATION */
/* simulated processes are computed with the pooled sample estimator f01 */
/* (simulations with pooled sample f01 lead to conservative test, */
/* recommended by Bajorunatite & Klein (2007, CSDA); */
/* individual f11, f21 give anticonserv. approximation) */
if (*nsim>0) {
*pval_sim = 0.;
/* *pval_sim_indiv = 0.; */
for (j=0; j<*nsim_plot; j++) { /* always must be *nsim>=*nsim_plot */
for (i=0; i<*n; i++) {
g[i] = norm_rand();
}
/* compute the resampled test process with pooled sample f01 */
twosample_incidence_lwy_process(event, group, n, y1, y2, f01, f12, f01, f22,
g, test_process_sim);
stat_sim = ks_stat_cum(test_process_sim, n);
*pval_sim += (double) (stat_sim > *stat);
/* save the simulated process for plotting */
for (i=0; i<*n; i++)
test_process_plot_sim[i+j**n] = test_process_sim[i];
/* resampling with individual f11,f21; not used */
/*
twosample_incidence_lwy_process(event, group, n, y1, y2, f11, f12, f21, f22,
g, test_process_sim);
stat_sim = ks_stat_cum(test_process_sim, n, i1, i2);
*pval_sim_indiv += (double) (stat_sim > *stat);
*/
}
for (j=*nsim_plot; j<*nsim; j++) {
for (i=0; i<*n; i++) {
g[i] = norm_rand();
}
/* compute the resampled test process with pooled sample f01 */
twosample_incidence_lwy_process(event, group, n, y1, y2, f01, f12, f01, f22,
g, test_process_sim);
stat_sim = ks_stat_cum(test_process_sim, n);
*pval_sim += (double) (stat_sim > *stat);
/* resampling with individual f11,f21; not used */
/*
twosample_incidence_lwy_process(event, group, n, y1, y2, f11, f12, f21, f22,
g, test_process_sim);
stat_sim = ks_stat_cum(test_process_sim, n, i1, i2);
*pval_sim_indiv += (double) (stat_sim > *stat);
*/
}
*pval_sim /= *nsim;
/* *pval_sim_indiv /= *nsim; */
}
PutRNGstate();
}
SEXP thinjumpequal(SEXP n,
SEXP p,
SEXP guess)
{
int N;
double P;
int *w; /* temporary storage for selected integers */
int nw, nwmax;
int i, j, k;
double log1u, log1p;
/* R object return value */
SEXP Out;
/* external storage pointer */
int *OutP;
/* protect R objects from garbage collector */
PROTECT(p = AS_NUMERIC(p));
PROTECT(n = AS_INTEGER(n));
PROTECT(guess = AS_INTEGER(guess));
/* Translate arguments from R to C */
N = *(INTEGER_POINTER(n));
P = *(NUMERIC_POINTER(p));
nwmax = *(INTEGER_POINTER(guess));
/* Allocate space for result */
w = (int *) R_alloc(nwmax, sizeof(int));
/* set up */
GetRNGstate();
log1p = -log(1.0 - P);
/* main loop */
i = 0; /* last selected element of 1...N */
nw = 0; /* number of selected elements */
while(i <= N) {
log1u = exp_rand(); /* an exponential rv is equivalent to -log(1-U) */
j = (int) ceil(log1u/log1p); /* j is geometric(p) */
i += j;
if(nw >= nwmax) {
/* overflow; allocate more space */
w = (int *) S_realloc((char *) w, 2 * nwmax, nwmax, sizeof(int));
nwmax = 2 * nwmax;
}
/* add 'i' to output vector */
w[nw] = i;
++nw;
}
/* The last saved 'i' could have exceeded 'N' */
/* For efficiency we don't check this in the loop */
if(nw > 0 && w[nw-1] > N)
--nw;
PutRNGstate();
/* create result vector */
PROTECT(Out = NEW_INTEGER(nw));
/* copy results into output */
OutP = INTEGER_POINTER(Out);
for(k = 0; k < nw; k++)
OutP[k] = w[k];
UNPROTECT(4);
return(Out);
}
void gplot_layout_fruchtermanreingold_R(double *d, double *pn, double *pm,
int *pniter, double *pmaxdelta, double *pvolume, double *pcoolexp, double
*prepulserad, int *pncell, double *pcjit, double *pcppr, double *pcpcr, double
*pcccr, double *x, double *y)
/*
Calculate a two-dimensional Fruchterman-Reingold layout for (symmetrized)
edgelist matrix d (2 column). Positions (stored in (x,y)) should be initialized
prior to calling this routine.
*/
{
double frk,maxdelta,volume,coolexp,repulserad,t,ded,xd,yd,*dx,*dy;
double rf,af,xmax,xmin,ymax,ymin,xwid,ywid,cjit,cppr,cpcr,cccr,celldis;
long int n,j,k,l,m;
int niter,i,*cellid,ncell,ix,iy,jx,jy;
char *vmax;
vcell *vcells,*p,*p2;
vlist *vlp,*vlp2;
/*Define various things*/
n=(long int)*pn;
m=(long int)*pm;
niter=*pniter;
maxdelta=*pmaxdelta;
volume=*pvolume;
coolexp=*pcoolexp;
repulserad=*prepulserad;
ncell=*pncell;
cjit=*pcjit;
cppr=*pcppr;
cpcr=*pcpcr;
cccr=*pcccr;
frk=sqrt(volume/(double)n); /*Define the F-R constant*/
xmin=ymin=R_PosInf;
xmax=ymax=R_NegInf;
/*Allocate memory for transient structures*/
dx=(double *)R_alloc(n,sizeof(double));
dy=(double *)R_alloc(n,sizeof(double));
cellid=(int *)R_alloc(n,sizeof(int));
/*Run the annealing loop*/
for(i=niter;i>=0;i--){
/*Check for interrupts, before messing with temporary storage*/
R_CheckUserInterrupt();
/*Allocate cell structures for this iteration*/
GetRNGstate();
vmax=vmaxget();
xmin=ymin=R_PosInf;
xmax=ymax=R_NegInf;
for(j=0;j<n;j++){ /*Get current extrema to form cells*/
xmin=MIN(xmin,x[j]);
ymin=MIN(ymin,y[j]);
xmax=MAX(xmax,x[j]);
ymax=MAX(ymax,y[j]);
}
xmin-=0.0001*(xmax-xmin);
ymin-=0.0001*(ymax-ymin);
xmax+=0.0001*(xmax-xmin);
ymax+=0.0001*(ymax-ymin);
xwid=(xmax-xmin)/((double)ncell);
ywid=(ymax-ymin)/((double)ncell);
vcells=NULL;
for(j=0;j<n;j++){ /*Assign each vertex to a cell*/
jx=MAX(MIN(x[j]+rnorm(0.0,xwid*cjit),xmax),xmin); /*Jitter for memb*/
jy=MAX(MIN(y[j]+rnorm(0.0,ywid*cjit),ymax),ymin);
cellid[j]=(int)(floor((jx-xmin)/xwid)+ncell*floor((jy-ymin)/ywid));
/*Find j's cell (or create an entry, if not already present)*/
for(p=vcells;(p!=NULL)&&(p->next!=NULL)&&(p->id!=cellid[j]);p=p->next);
if(p==NULL){ /*Head was null; initiate*/
vcells=p=(vcell *)R_alloc(1,sizeof(vcell));
p->id=cellid[j];
p->next=NULL;
p->memb=NULL;
p->count=0.0;
p->xm=0.0;
p->ym=0.0;
}else if(p->id!=cellid[j]){ /*Got to end, insert new element*/
p->next=(vcell *)R_alloc(1,sizeof(vcell));
p=p->next;
p->id=cellid[j];
p->next=NULL;
p->memb=NULL;
p->count=0.0;
p->xm=0.0;
p->ym=0.0;
}
/*Add j to the membership stack for this cell*/
p->count++;
vlp=(vlist *)R_alloc(1,sizeof(vlist));
vlp->v=j;
vlp->next=p->memb;
p->memb=vlp;
p->xm=((p->xm)*((p->count)-1.0)+x[j])/(p->count);
p->ym=((p->ym)*((p->count)-1.0)+y[j])/(p->count);
}
PutRNGstate();
/*Set the temperature (maximum move/iteration)*/
t=maxdelta*pow(i/(double)niter,coolexp);
/*Clear the deltas*/
for(j=0;j<n;j++){
dx[j]=0.0;
dy[j]=0.0;
}
/*Increment deltas for general force effects, using cells*/
for(p=vcells;p!=NULL;p=p->next) /*Add forces at the cell level*/
for(p2=p;p2!=NULL;p2=p2->next){
/*Get cell identities*/
ix=(p->id)%ncell;
jx=(p2->id)%ncell;
iy=(int)floor((p->id)/ncell);
jy=(int)floor((p2->id)/ncell);
celldis=(double)((ix-jx)*(ix-jx)+(iy-jy)*(iy-jy)); /*Sq cell/cell dist*/
if(celldis<=cppr+0.001){ /*Use point/point calculations (exact)*/
for(vlp=p->memb;vlp!=NULL;vlp=vlp->next)
for(vlp2=((p==p2)?(vlp->next):(p2->memb));vlp2!=NULL; vlp2=vlp2->next){
/*Obtain difference vector*/
xd=x[vlp->v]-x[vlp2->v];
yd=y[vlp->v]-y[vlp2->v];
ded=sqrt(xd*xd+yd*yd); /*Get dyadic euclidean distance*/
xd/=ded; /*Rescale differences to length 1*/
yd/=ded;
/*Calculate repulsive "force"*/
rf=frk*frk*(1.0/ded-ded*ded/repulserad);
dx[vlp->v]+=xd*rf; /*Add to the position change vector*/
dx[vlp2->v]-=xd*rf;
dy[vlp->v]+=yd*rf;
dy[vlp2->v]-=yd*rf;
}
}else if(celldis<=cpcr+0.001){ /*Use point/cell calculations (approx)*/
/*Add force increments to each member of p and p2*/
for(vlp=p->memb;vlp!=NULL;vlp=vlp->next){
xd=x[vlp->v]-(p2->xm);
yd=y[vlp->v]-(p2->ym);
ded=sqrt(xd*xd+yd*yd); /*Get dyadic euclidean distance*/
xd/=ded; /*Rescale differences to length 1*/
yd/=ded;
/*Calculate repulsive "force"*/
rf=frk*frk*(1.0/ded-ded*ded/repulserad);
/*Add to dx and dy*/
dx[vlp->v]+=xd*rf*(p2->count);
dy[vlp->v]+=yd*rf*(p2->count);
}
for(vlp=p2->memb;vlp!=NULL;vlp=vlp->next){
xd=x[vlp->v]-(p->xm);
yd=y[vlp->v]-(p->ym);
ded=sqrt(xd*xd+yd*yd); /*Get dyadic euclidean distance*/
xd/=ded; /*Rescale differences to length 1*/
yd/=ded;
/*Calculate repulsive "force"*/
rf=frk*frk*(1.0/ded-ded*ded/repulserad);
/*Add to dx and dy*/
dx[vlp->v]+=xd*rf*(p->count);
dy[vlp->v]+=yd*rf*(p->count);
}
}else if(celldis<=cccr+0.001){ /*Use cell/cell calculations (crude!)*/
xd=(p->xm)-(p2->xm);
yd=(p->ym)-(p2->ym);
ded=sqrt(xd*xd+yd*yd); /*Get dyadic euclidean distance*/
xd/=ded; /*Rescale differences to length 1*/
yd/=ded;
/*Calculate repulsive "force"*/
rf=frk*frk*(1.0/ded-ded*ded/repulserad);
/*Add force increment to each member of p and p2*/
for(vlp=p->memb;vlp!=NULL;vlp=vlp->next){
dx[vlp->v]+=xd*rf*(p2->count);
dy[vlp->v]+=yd*rf*(p2->count);
}
for(vlp=p2->memb;vlp!=NULL;vlp=vlp->next){
dx[vlp->v]-=xd*rf*(p->count);
dy[vlp->v]-=yd*rf*(p->count);
}
}
}
/*Calculate attraction along edges*/
for(j=0;j<m;j++){
k=(long int)d[j]-1; /*Subtract 1, b/c R uses 1:n, not 0:(n-1)*/
l=(long int)d[j+m]-1;
xd=x[k]-x[l];
yd=y[k]-y[l];
ded=sqrt(xd*xd+yd*yd); /*Get dyadic euclidean distance*/
af=d[j+2*m]*ded*ded/frk;
dx[k]-=xd*af; /*Add to the position change vector*/
dx[l]+=xd*af;
dy[k]-=yd*af;
dy[l]+=yd*af;
}
/*Dampen motion, if needed, and move the points*/
for(j=0;j<n;j++){
ded=sqrt(dx[j]*dx[j]+dy[j]*dy[j]);
if(ded>t){ /*Dampen to t*/
ded=t/ded;
dx[j]*=ded;
dy[j]*=ded;
}
x[j]+=dx[j]; /*Update positions*/
y[j]+=dy[j];
}
/*Free memory for cell membership (or at least unprotect it)*/
vmaxset(vmax);
}
}
SEXP pollSocket(SEXP sockets_, SEXP events_, SEXP timeout_) {
SEXP result;
if(TYPEOF(timeout_) != INTSXP) {
error("poll timeout must be an integer.");
}
if(TYPEOF(sockets_) != VECSXP || LENGTH(sockets_) == 0) {
error("A non-empy list of sockets is required as first argument.");
}
int nsock = LENGTH(sockets_);
PROTECT(result = allocVector(VECSXP, nsock));
if (TYPEOF(events_) != VECSXP) {
error("event list must be a list of strings or a list of vectors of strings.");
}
if(LENGTH(events_) != nsock) {
error("event list must be the same length as socket list.");
}
zmq_pollitem_t *pitems = (zmq_pollitem_t*)R_alloc(nsock, sizeof(zmq_pollitem_t));
if (pitems == NULL) {
error("failed to allocate memory for zmq_pollitem_t array.");
}
try {
for (int i = 0; i < nsock; i++) {
zmq::socket_t* socket = reinterpret_cast<zmq::socket_t*>(checkExternalPointer(VECTOR_ELT(sockets_, i), "zmq::socket_t*"));
pitems[i].socket = (void*)*socket;
pitems[i].events = rzmq_build_event_bitmask(VECTOR_ELT(events_, i));
}
int rc = zmq::poll(pitems, nsock, *INTEGER(timeout_));
if(rc >= 0) {
for (int i = 0; i < nsock; i++) {
SEXP events, names;
// Pre count number of polled events so we can
// allocate appropriately sized lists.
short eventcount = 0;
if (pitems[i].events & ZMQ_POLLIN) eventcount++;
if (pitems[i].events & ZMQ_POLLOUT) eventcount++;
if (pitems[i].events & ZMQ_POLLERR) eventcount++;
PROTECT(events = allocVector(VECSXP, eventcount));
PROTECT(names = allocVector(VECSXP, eventcount));
eventcount = 0;
if (pitems[i].events & ZMQ_POLLIN) {
SET_VECTOR_ELT(events, eventcount, ScalarLogical(pitems[i].revents & ZMQ_POLLIN));
SET_VECTOR_ELT(names, eventcount, mkChar("read"));
eventcount++;
}
if (pitems[i].events & ZMQ_POLLOUT) {
SET_VECTOR_ELT(names, eventcount, mkChar("write"));
SET_VECTOR_ELT(events, eventcount, ScalarLogical(pitems[i].revents & ZMQ_POLLOUT));
eventcount++;
}
if (pitems[i].events & ZMQ_POLLERR) {
SET_VECTOR_ELT(names, eventcount, mkChar("error"));
SET_VECTOR_ELT(events, eventcount, ScalarLogical(pitems[i].revents & ZMQ_POLLERR));
}
setAttrib(events, R_NamesSymbol, names);
SET_VECTOR_ELT(result, i, events);
}
} else {
error("polling zmq sockets failed.");
}
} catch(std::exception& e) {
error(e.what());
}
// Release the result list (1), and per socket
// events lists with associated names (2*nsock).
UNPROTECT(1 + 2*nsock);
return result;
}
void gplot3d_layout_fruchtermanreingold_R(double *d, int *pn, int *pm, int *pniter, double *pmaxdelta, double *pvolume, double *pcoolexp, double *prepulserad, double *x, double *y, double *z)
/*
Calculate a three-dimensional Fruchterman-Reingold layout for (symmetrized)
edgelist matrix d. Positions (stored in (x,y,z)) should be initialized
prior to calling this routine.
*/
{
double frk,maxdelta,volume,coolexp,repulserad,t,ded,xd,yd,zd,*dx,*dy,*dz;
double rf,af;
int n,j,k,niter,i,m,l;
/*Define various things*/
n=(int)*pn;
m=(int)*pm;
niter=*pniter;
maxdelta=*pmaxdelta;
volume=*pvolume;
coolexp=*pcoolexp;
repulserad=*prepulserad;
frk=pow(volume/(double)n,1.0/3.0); /*Define the F-R constant*/
/*Allocate memory for transient structures*/
dx=(double *)R_alloc(n,sizeof(double));
dy=(double *)R_alloc(n,sizeof(double));
dz=(double *)R_alloc(n,sizeof(double));
/*Run the annealing loop*/
for(i=niter;i>=0;i--){
/*Set the temperature (maximum move/iteration)*/
t=maxdelta*pow(i/(double)niter,coolexp);
/*Clear the deltas*/
for(j=0;j<n;j++){
dx[j]=0.0;
dy[j]=0.0;
dz[j]=0.0;
}
/*Increment deltas for each undirected pair*/
for(j=0;j<n;j++)
for(k=j+1;k<n;k++){
/*Obtain difference vector*/
xd=x[j]-x[k];
yd=y[j]-y[k];
zd=z[j]-z[k];
ded=sqrt(xd*xd+yd*yd+zd*zd); /*Get dyadic euclidean distance*/
xd/=ded; /*Rescale differences to length 1*/
yd/=ded;
zd/=ded;
/*Calculate repulsive "force"*/
rf=frk*frk*(1.0/ded-ded*ded/repulserad);
dx[j]+=xd*rf; /*Add to the position change vector*/
dx[k]-=xd*rf;
dy[j]+=yd*rf;
dy[k]-=yd*rf;
dz[j]+=zd*rf;
dz[k]-=zd*rf;
}
/*Calculate the attractive "force"*/
for(j=0;j<m;j++){
k=(int)d[j]-1;
l=(int)d[j+m]-1;
if(k<l){
xd=x[k]-x[l];
yd=y[k]-y[l];
zd=z[k]-z[l];
ded=sqrt(xd*xd+yd*yd+zd*zd); /*Get dyadic euclidean distance*/
xd/=ded; /*Rescale differences to length 1*/
yd/=ded;
zd/=ded;
af=d[j+2*m]*ded*ded/frk;
dx[k]-=xd*af; /*Add to the position change vector*/
dx[l]+=xd*af;
dy[k]-=yd*af;
dy[l]+=yd*af;
dz[k]-=zd*af;
dz[l]+=zd*af;
}
}
/*Dampen motion, if needed, and move the points*/
for(j=0;j<n;j++){
ded=sqrt(dx[j]*dx[j]+dy[j]*dy[j]+dz[j]*dz[j]);
if(ded>t){ /*Dampen to t*/
ded=t/ded;
dx[j]*=ded;
dy[j]*=ded;
dz[j]*=ded;
}
x[j]+=dx[j]; /*Update positions*/
y[j]+=dy[j];
z[j]+=dz[j];
}
}
}
static SEXP readRegistryKey1(HKEY hkey, const wchar_t *name)
{
SEXP ans = R_NilValue;
LONG res;
DWORD type, size0 = 10000, size = size0;
BYTE data[10000], *d = data;
res = RegQueryValueExW(hkey, name, NULL, &type, d, &size);
while (res == ERROR_MORE_DATA) {
size0 *= 10;
size = size0;
d = (BYTE *) R_alloc(size0, sizeof(char));
res = RegQueryValueExW(hkey, name, NULL, &type, d, &size);
}
if (res != ERROR_SUCCESS) return ans;
switch(type) {
case REG_NONE:
/* NULL */
break;
case REG_DWORD:
ans = allocVector(INTSXP, 1);
memcpy(INTEGER(ans), d, 4);
break;
case REG_DWORD_BIG_ENDIAN:
{
BYTE d4[4];
int i;
for(i = 0; i < 4; i++) d4[3-i] = d[i];
ans = allocVector(INTSXP, 1);
memcpy(INTEGER(ans), d4, 4);
break;
}
case REG_SZ:
case REG_EXPAND_SZ:
{
PROTECT(ans = allocVector(STRSXP, 1));
SET_STRING_ELT(ans, 0, mkCharUcs((wchar_t *)d));
UNPROTECT(1);
break;
}
case REG_BINARY:
ans = allocVector(RAWSXP, size);
memcpy(RAW(ans), d, size);
break;
case REG_MULTI_SZ:
{
int i, n;
wchar_t *p = (wchar_t *)d;
for (n = 0; *p; n++) { for(; *p; p++) {}; p++; }
PROTECT(ans = allocVector(STRSXP, n));
for (i = 0, p = (wchar_t *)d; i < n; i++) {
SET_STRING_ELT(ans, i, mkCharUcs(p));
for(; *p; p++) {};
p++;
}
UNPROTECT(1);
break;
}
case REG_LINK:
warning("unhandled key type %s\n", "REG_LINK");
ans = mkString("<REG_LINK>");
break;
case REG_RESOURCE_LIST:
warning("unhandled key type %s\n", "REG_RESOURCE_LIST");
ans = mkString("<REG_RESOURCE_LIST>");
break;
default:
warning("unhandled key type %d\n", type);
}
return ans;
}
void moaftme_sample_rho(double *X,
int *Z,
double *rho, // note: input and output
double *gamma0,
double *tune,
int *nptr,
int *pptr,
int *Jptr,
int *accepts
) {
int n = *nptr;
int p = *pptr;
int J = *Jptr;
int i, j, k;
//Rprintf("n=%d p=%d J=%d\n", n, p, J);
// for each j
// generate candidate rho_j
// evaluate logpost(rho_j candidate)
// evaluate logpost(rho_j current)
// evaluate alpha
// accept or reject rho_j candidate
double *cand_rho = (double *) R_alloc(p, sizeof(double));
double *current_rho = (double *) R_alloc(p, sizeof(double));
// we start from 1 because first rho is always zero.
for (j=1; j < J; ++j) {
// generate candidate rho_j
for (k=0; k < p; ++k) {
cand_rho[k] = rnorm(rho[j + J*k], tune[j]);
}
double log_post_cand_rho = moaftme_log_post_rho_j(j,
cand_rho,
rho,
X,
Z,
gamma0,
n,
p,
J);
// a copy of current rho_j
for (k=0; k < p; ++k) {
current_rho[k] = rho[j + J*k];
}
double log_post_current_rho = moaftme_log_post_rho_j(j,
current_rho,
rho,
X,
Z,
gamma0,
n,
p,
J);
double ratio = exp(log_post_cand_rho - log_post_current_rho);
if (runif(0, 1) < ratio) {
// copy cand_rho into rho
for (k=0; k < p; ++k) {
rho[j + J*k] = cand_rho[k];
}
accepts[j] += 1;
}
// else rho stays the same.
}
}
SEXP spMisalign(SEXP Y_r, SEXP X_r, SEXP p_r, SEXP n_r, SEXP m_r, SEXP coordsD_r,
SEXP betaPrior_r, SEXP betaNorm_r,
SEXP KPrior_r, SEXP KPriorName_r,
SEXP PsiPrior_r,
SEXP nuUnif_r, SEXP phiUnif_r,
SEXP phiStarting_r, SEXP AStarting_r, SEXP PsiStarting_r, SEXP nuStarting_r,
SEXP phiTuning_r, SEXP ATuning_r, SEXP PsiTuning_r, SEXP nuTuning_r,
SEXP nugget_r, SEXP covModel_r, SEXP amcmc_r, SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, SEXP verbose_r, SEXP nReport_r){
/*****************************************
Common variables
*****************************************/
int h, i, j, k, l, b, s, ii, jj, kk, info, nProtect= 0;
char const *lower = "L";
char const *upper = "U";
char const *nUnit = "N";
char const *yUnit = "U";
char const *ntran = "N";
char const *ytran = "T";
char const *rside = "R";
char const *lside = "L";
const double one = 1.0;
const double negOne = -1.0;
const double zero = 0.0;
const int incOne = 1;
/*****************************************
Set-up
*****************************************/
double *Y = REAL(Y_r);
double *X = REAL(X_r);
int *p = INTEGER(p_r);
int *n = INTEGER(n_r);
int m = INTEGER(m_r)[0];
int nLTr = m*(m-1)/2+m;
int N = 0;
int P = 0;
for(i = 0; i < m; i++){
N += n[i];
P += p[i];
}
int mm = m*m;
int NN = N*N;
int NP = N*P;
int PP = P*P;
double *coordsD = REAL(coordsD_r);
std::string covModel = CHAR(STRING_ELT(covModel_r,0));
//priors
std::string betaPrior = CHAR(STRING_ELT(betaPrior_r,0));
double *betaMu = NULL;
double *betaC = NULL;
if(betaPrior == "normal"){
betaMu = (double *) R_alloc(P, sizeof(double));
F77_NAME(dcopy)(&P, REAL(VECTOR_ELT(betaNorm_r, 0)), &incOne, betaMu, &incOne);
betaC = (double *) R_alloc(PP, sizeof(double));
F77_NAME(dcopy)(&PP, REAL(VECTOR_ELT(betaNorm_r, 1)), &incOne, betaC, &incOne);
}
double *phiUnif = REAL(phiUnif_r);
std::string KPriorName = CHAR(STRING_ELT(KPriorName_r,0));
double KIW_df = 0; double *KIW_S = NULL;
double *ANormMu = NULL; double *ANormC = NULL;
if(KPriorName == "IW"){
KIW_S = (double *) R_alloc(mm, sizeof(double));
KIW_df = REAL(VECTOR_ELT(KPrior_r, 0))[0]; KIW_S = REAL(VECTOR_ELT(KPrior_r, 1));
}else{//assume A normal (can add more specifications later)
ANormMu = (double *) R_alloc(nLTr, sizeof(double));
ANormC = (double *) R_alloc(nLTr, sizeof(double));
for(i = 0; i < nLTr; i++){
ANormMu[i] = REAL(VECTOR_ELT(KPrior_r, 0))[i];
ANormC[i] = REAL(VECTOR_ELT(KPrior_r, 1))[i];
}
}
bool nugget = static_cast<bool>(INTEGER(nugget_r)[0]);
double *PsiIGa = NULL; double *PsiIGb = NULL;
if(nugget){
PsiIGa = (double *) R_alloc(m, sizeof(double));
PsiIGb = (double *) R_alloc(m, sizeof(double));
for(i = 0; i < m; i++){
PsiIGa[i] = REAL(VECTOR_ELT(PsiPrior_r, 0))[i];
PsiIGb[i] = REAL(VECTOR_ELT(PsiPrior_r, 1))[i];
}
}
//matern
double *nuUnif = NULL;
if(covModel == "matern"){
nuUnif = REAL(nuUnif_r);
}
bool amcmc = static_cast<bool>(INTEGER(amcmc_r)[0]);
int nBatch = INTEGER(nBatch_r)[0];
int batchLength = INTEGER(batchLength_r)[0];
double acceptRate = REAL(acceptRate_r)[0];
int nSamples = nBatch*batchLength;
int verbose = INTEGER(verbose_r)[0];
int nReport = INTEGER(nReport_r)[0];
if(verbose){
Rprintf("----------------------------------------\n");
Rprintf("\tGeneral model description\n");
Rprintf("----------------------------------------\n");
Rprintf("Model fit with %i outcome variables.\n\n", m);
Rprintf("Number of observations within each outcome:"); printVec(n, m);
Rprintf("\nNumber of covariates for each outcome (including intercept if specified):"); printVec(p, m);
Rprintf("\nTotal number of observations: %i\n\n", N);
Rprintf("Total number of covariates (including intercept if specified): %i\n\n", P);
Rprintf("Using the %s spatial correlation model.\n\n", covModel.c_str());
if(amcmc){
Rprintf("Using adaptive MCMC.\n\n");
Rprintf("\tNumber of batches %i.\n", nBatch);
Rprintf("\tBatch length %i.\n", batchLength);
Rprintf("\ttarget acceptance rate %.5f.\n", acceptRate);
Rprintf("\n");
}else{
Rprintf("Number of MCMC samples %i.\n\n", nSamples);
}
if(!nugget){
Rprintf("Psi not included in the model (i.e., no nugget model).\n\n");
}
Rprintf("Priors and hyperpriors:\n");
if(betaPrior == "flat"){
Rprintf("\tbeta flat.\n");
}else{
Rprintf("\tbeta normal:\n");
Rprintf("\tmu:"); printVec(betaMu, P);
Rprintf("\tcov:\n"); printMtrx(betaC, P, P);
}
Rprintf("\n");
if(KPriorName == "IW"){
Rprintf("\tK IW hyperpriors df=%.5f, S=\n", KIW_df);
printMtrx(KIW_S, m, m);
}else{
Rprintf("\tA Normal hyperpriors\n");
Rprintf("\t\tparameter\tmean\tvar\n");
for(j = 0, i = 0; j < m; j++){
for(k = j; k < m; k++, i++){
Rprintf("\t\tA[%i,%i]\t\t%3.1f\t%1.2f\n", j+1, k+1, ANormMu[i], ANormC[i]);
}
}
}
Rprintf("\n");
if(nugget){
Rprintf("\tDiag(Psi) IG hyperpriors\n");
Rprintf("\t\tparameter\tshape\tscale\n");
for(j = 0; j < m; j++){
Rprintf("\t\tPsi[%i,%i]\t%3.1f\t%1.2f\n", j+1, j+1, PsiIGa[j], PsiIGb[j]);
}
}
Rprintf("\n");
Rprintf("\tphi Unif hyperpriors\n");
Rprintf("\t\tparameter\ta\tb\n");
for(j = 0; j < m; j++){
Rprintf("\t\tphi[%i]\t\t%0.5f\t%0.5f\n", j+1, phiUnif[j*2], phiUnif[j*2+1]);
}
Rprintf("\n");
if(covModel == "matern"){
Rprintf("\tnu Unif hyperpriors\n");
for(j = 0; j < m; j++){
Rprintf("\t\tnu[%i]\t\t%0.5f\t%0.5f\n", j+1, nuUnif[j*2], nuUnif[j*2+1]);
}
Rprintf("\n");
}
}
/*****************************************
Set-up MCMC sample matrices etc.
*****************************************/
//spatial parameters
int nParams, AIndx, PsiIndx, phiIndx, nuIndx;
if(!nugget && covModel != "matern"){
nParams = nLTr+m;//A, phi
AIndx = 0; phiIndx = nLTr;
}else if(nugget && covModel != "matern"){
nParams = nLTr+m+m;//A, diag(Psi), phi
AIndx = 0; PsiIndx = nLTr; phiIndx = PsiIndx+m;
}else if(!nugget && covModel == "matern"){
nParams = nLTr+2*m;//A, phi, nu
AIndx = 0; phiIndx = nLTr, nuIndx = phiIndx+m;
}else{
nParams = nLTr+3*m;//A, diag(Psi), phi, nu
AIndx = 0; PsiIndx = nLTr, phiIndx = PsiIndx+m, nuIndx = phiIndx+m;
}
double *params = (double *) R_alloc(nParams, sizeof(double));
//starting
covTrans(REAL(AStarting_r), ¶ms[AIndx], m);
if(nugget){
for(i = 0; i < m; i++){
params[PsiIndx+i] = log(REAL(PsiStarting_r)[i]);
}
}
for(i = 0; i < m; i++){
params[phiIndx+i] = logit(REAL(phiStarting_r)[i], phiUnif[i*2], phiUnif[i*2+1]);
if(covModel == "matern"){
params[nuIndx+i] = logit(REAL(nuStarting_r)[i], nuUnif[i*2], nuUnif[i*2+1]);
}
}
//tuning and fixed
double *tuning = (double *) R_alloc(nParams, sizeof(double));
int *fixed = (int *) R_alloc(nParams, sizeof(int)); zeros(fixed, nParams);
for(i = 0; i < nLTr; i++){
tuning[AIndx+i] = REAL(ATuning_r)[i];
if(tuning[AIndx+i] == 0){
fixed[AIndx+i] = 1;
}
}
if(nugget){
for(i = 0; i < m; i++){
tuning[PsiIndx+i] = REAL(PsiTuning_r)[i];
if(tuning[PsiIndx+i] == 0){
fixed[PsiIndx+i] = 1;
}
}
}
for(i = 0; i < m; i++){
tuning[phiIndx+i] = REAL(phiTuning_r)[i];
if(tuning[phiIndx+i] == 0){
fixed[phiIndx+i] = 1;
}
if(covModel == "matern"){
tuning[nuIndx+i] = REAL(nuTuning_r)[i];
if(tuning[nuIndx+i] == 0){
fixed[nuIndx+i] = 1;
}
}
}
for(i = 0; i < nParams; i++){
tuning[i] = log(sqrt(tuning[i]));
}
//return stuff
SEXP samples_r, accept_r, tuning_r;
PROTECT(samples_r = allocMatrix(REALSXP, nParams, nSamples)); nProtect++;
if(amcmc){
PROTECT(accept_r = allocMatrix(REALSXP, nParams, nBatch)); nProtect++;
PROTECT(tuning_r = allocMatrix(REALSXP, nParams, nBatch)); nProtect++;
}else{
PROTECT(accept_r = allocMatrix(REALSXP, 1, nSamples/nReport)); nProtect++;
}
// /*****************************************
// Set-up MCMC alg. vars. matrices etc.
// *****************************************/
int status=1, batchAccept=0, reportCnt=0;
double logMHRatio =0, logPostCurrent = R_NegInf, logPostCand = 0, det = 0, paramsjCurrent = 0;
double Q, logDetK, SKtrace;
double *paramsCurrent = (double *) R_alloc(nParams, sizeof(double));
double *accept = (double *) R_alloc(nParams, sizeof(double)); zeros(accept, nParams);
double *C = (double *) R_alloc(NN, sizeof(double));
double *K = (double *) R_alloc(mm, sizeof(double));
double *Psi = (double *) R_alloc(m, sizeof(double));
double *A = (double *) R_alloc(mm, sizeof(double));
double *phi = (double *) R_alloc(m, sizeof(double));
double *nu = (double *) R_alloc(m, sizeof(double));
int P1 = P+1;
double *vU = (double *) R_alloc(N*P1, sizeof(double));
double *z = (double *) R_alloc(N, sizeof(double));
double *tmp_N = (double *) R_alloc(N, sizeof(double));
double *tmp_mm = (double *) R_alloc(mm, sizeof(double));
double *tmp_PP = (double *) R_alloc(PP, sizeof(double));
double *tmp_P = (double *) R_alloc(P, sizeof(double));
double *tmp_NN = NULL;
double *Cbeta = NULL;
if(betaPrior == "normal"){
tmp_NN = (double *) R_alloc(NN, sizeof(double));
Cbeta = (double *) R_alloc(NN, sizeof(double));
F77_NAME(dgemv)(ntran, &N, &P, &negOne, X, &N, betaMu, &incOne, &zero, z, &incOne);
F77_NAME(daxpy)(&N, &one, Y, &incOne, z, &incOne);
F77_NAME(dsymm)(rside, lower, &N, &P, &one, betaC, &P, X, &N, &zero, vU, &N);
F77_NAME(dgemm)(ntran, ytran, &N, &N, &P, &one, vU, &N, X, &N, &zero, tmp_NN, &N);
}
int sl, sk;
if(verbose){
Rprintf("-------------------------------------------------\n");
Rprintf("\t\tSampling\n");
Rprintf("-------------------------------------------------\n");
#ifdef Win32
R_FlushConsole();
#endif
}
GetRNGstate();
for(b = 0, s = 0; b < nBatch; b++){
for(i = 0; i < batchLength; i++, s++){
for(j = 0; j < nParams; j++){
//propose
if(amcmc){
if(fixed[j] == 1){
paramsjCurrent = params[j];
}else{
paramsjCurrent = params[j];
params[j] = rnorm(paramsjCurrent, exp(tuning[j]));
}
}else{
F77_NAME(dcopy)(&nParams, params, &incOne, paramsCurrent, &incOne);
for(j = 0; j < nParams; j++){
if(fixed[j] == 1){
params[j] = params[j];
}else{
params[j] = rnorm(params[j], exp(tuning[j]));
}
}
}
//extract and transform
covTransInvExpand(¶ms[AIndx], A, m);
for(k = 0; k < m; k++){
phi[k] = logitInv(params[phiIndx+k], phiUnif[k*2], phiUnif[k*2+1]);
if(covModel == "matern"){
nu[k] = logitInv(params[nuIndx+k], nuUnif[k*2], nuUnif[k*2+1]);
}
}
if(nugget){
for(k = 0; k < m; k++){
Psi[k] = exp(params[PsiIndx+k]);
}
}
//construct covariance matrix
sl = sk = 0;
for(k = 0; k < m; k++){
sl = 0;
for(l = 0; l < m; l++){
for(kk = 0; kk < n[k]; kk++){
for(jj = 0; jj < n[l]; jj++){
C[(sl+jj)*N+(sk+kk)] = 0.0;
for(ii = 0; ii < m; ii++){
C[(sl+jj)*N+(sk+kk)] += A[k+m*ii]*A[l+m*ii]*spCor(coordsD[(sl+jj)*N+(sk+kk)], phi[ii], nu[ii], covModel);
}
}
}
sl += n[l];
}
sk += n[k];
}
if(nugget){
sl = 0;
for(l = 0; l < m; l++){
for(k = 0; k < n[l]; k++){
C[(sl+k)*N+(sl+k)] += Psi[l];
}
sl += n[l];
}
}
if(betaPrior == "normal"){
for(k = 0; k < N; k++){
for(l = k; l < N; l++){
Cbeta[k*N+l] = C[k*N+l]+tmp_NN[k*N+l];
}
}
det = 0;
F77_NAME(dpotrf)(lower, &N, Cbeta, &N, &info); if(info != 0){error("c++ error: dpotrf failed\n");}
for(k = 0; k < N; k++) det += 2*log(Cbeta[k*N+k]);
F77_NAME(dcopy)(&N, z, &incOne, tmp_N, &incOne);
F77_NAME(dtrsv)(lower, ntran, nUnit, &N, Cbeta, &N, tmp_N, &incOne);//u = L^{-1}(y-X'beta)
Q = pow(F77_NAME(dnrm2)(&N, tmp_N, &incOne),2);
}else{//beta flat
det = 0;
F77_NAME(dpotrf)(lower, &N, C, &N, &info); if(info != 0){error("c++ error: dpotrf failed\n");}
for(k = 0; k < N; k++) det += 2*log(C[k*N+k]);
F77_NAME(dcopy)(&N, Y, &incOne, vU, &incOne);
F77_NAME(dcopy)(&NP, X, &incOne, &vU[N], &incOne);
F77_NAME(dtrsm)(lside, lower, ntran, nUnit, &N, &P1, &one, C, &N, vU, &N);//L^{-1}[v:U] = [y:X]
F77_NAME(dgemm)(ytran, ntran, &P, &P, &N, &one, &vU[N], &N, &vU[N], &N, &zero, tmp_PP, &P); //U'U
F77_NAME(dpotrf)(lower, &P, tmp_PP, &P, &info); if(info != 0){error("c++ error: dpotrf failed\n");}
for(k = 0; k < P; k++) det += 2*log(tmp_PP[k*P+k]);
F77_NAME(dgemv)(ytran, &N, &P, &one, &vU[N], &N, vU, &incOne, &zero, tmp_P, &incOne); //U'v
F77_NAME(dtrsv)(lower, ntran, nUnit, &P, tmp_PP, &P, tmp_P, &incOne);
Q = pow(F77_NAME(dnrm2)(&N, vU, &incOne),2) - pow(F77_NAME(dnrm2)(&P, tmp_P, &incOne),2) ;
}
//
//priors, jacobian adjustments, and likelihood
//
logPostCand = 0.0;
if(KPriorName == "IW"){
logDetK = 0.0;
SKtrace = 0.0;
for(k = 0; k < m; k++){logDetK += 2*log(A[k*m+k]);}
//jacobian \sum_{i=1}^{m} (m-i+1)*log(a_ii)+log(a_ii)
for(k = 0; k < m; k++){logPostCand += (m-k)*log(A[k*m+k])+log(A[k*m+k]);}
//S*K^-1
F77_NAME(dpotri)(lower, &m, A, &m, &info); if(info != 0){error("c++ error: dpotri failed\n");}
F77_NAME(dsymm)(rside, lower, &m, &m, &one, A, &m, KIW_S, &m, &zero, tmp_mm, &m);
for(k = 0; k < m; k++){SKtrace += tmp_mm[k*m+k];}
logPostCand += -0.5*(KIW_df+m+1)*logDetK - 0.5*SKtrace;
}else{
for(k = 0; k < nLTr; k++){
logPostCand += dnorm(params[AIndx+k], ANormMu[k], sqrt(ANormC[k]), 1);
}
}
if(nugget){
for(k = 0; k < m; k++){
logPostCand += -1.0*(1.0+PsiIGa[k])*log(Psi[k])-PsiIGb[k]/Psi[k]+log(Psi[k]);
}
}
for(k = 0; k < m; k++){
logPostCand += log(phi[k] - phiUnif[k*2]) + log(phiUnif[k*2+1] - phi[k]);
if(covModel == "matern"){
logPostCand += log(nu[k] - nuUnif[k*2]) + log(nuUnif[k*2+1] - nu[k]);
}
}
logPostCand += -0.5*det-0.5*Q;
//
//MH accept/reject
//
logMHRatio = logPostCand - logPostCurrent;
if(runif(0.0,1.0) <= exp(logMHRatio)){
logPostCurrent = logPostCand;
if(amcmc){
accept[j]++;
}else{
accept[0]++;
batchAccept++;
}
}else{
if(amcmc){
params[j] = paramsjCurrent;
}else{
F77_NAME(dcopy)(&nParams, paramsCurrent, &incOne, params, &incOne);
}
}
if(!amcmc){
break;
}
}//end params
/******************************
Save samples
*******************************/
F77_NAME(dcopy)(&nParams, params, &incOne, &REAL(samples_r)[s*nParams], &incOne);
R_CheckUserInterrupt();
}//end batch
//adjust tuning
if(amcmc){
for(j = 0; j < nParams; j++){
REAL(accept_r)[b*nParams+j] = accept[j]/batchLength;
REAL(tuning_r)[b*nParams+j] = tuning[j];
if(accept[j]/batchLength > acceptRate){
tuning[j] += std::min(0.01, 1.0/sqrt(static_cast<double>(b)));
}else{
tuning[j] -= std::min(0.01, 1.0/sqrt(static_cast<double>(b)));
}
accept[j] = 0.0;
}
}
//report
if(status == nReport){
if(verbose){
if(amcmc){
Rprintf("Batch: %i of %i, %3.2f%%\n", b+1, nBatch, 100.0*(b+1)/nBatch);
Rprintf("\tparameter\tacceptance\ttuning\n");
for(j = 0, i = 0; j < m; j++){
for(k = j; k < m; k++, i++){
Rprintf("\tA[%i,%i]\t\t%3.1f\t\t%1.2f\n", j+1, k+1, 100.0*REAL(accept_r)[b*nParams+AIndx+i], exp(tuning[AIndx+i]));
}
}
if(nugget){
for(j = 0; j < m; j++){
Rprintf("\tPsi[%i,%i]\t%3.1f\t\t%1.2f\n", j+1, j+1, 100.0*REAL(accept_r)[b*nParams+PsiIndx+j], exp(tuning[PsiIndx+j]));
}
}
for(j = 0; j < m; j++){
Rprintf("\tphi[%i]\t\t%3.1f\t\t%1.2f\n", j+1, 100.0*REAL(accept_r)[b*nParams+phiIndx+j], exp(tuning[phiIndx+j]));
}
if(covModel == "matern"){
Rprintf("\n");
for(j = 0; j < m; j++){
Rprintf("\tnu[%i]\t\t%3.1f\t\t%1.2f\n", j+1, 100.0*REAL(accept_r)[b*nParams+nuIndx+j], exp(tuning[nuIndx+j]));
}
}
}else{
Rprintf("Sampled: %i of %i, %3.2f%%\n", s, nSamples, 100.0*s/nSamples);
Rprintf("Report interval Metrop. Acceptance rate: %3.2f%%\n", 100.0*batchAccept/nReport);
Rprintf("Overall Metrop. Acceptance rate: %3.2f%%\n", 100.0*accept[0]/s);
}
Rprintf("-------------------------------------------------\n");
#ifdef Win32
R_FlushConsole();
#endif
}
if(!amcmc){
REAL(accept_r)[reportCnt] = 100.0*batchAccept/nReport;
reportCnt++;
}
status = 0;
batchAccept = 0;
}
status++;
}//end sample loop
PutRNGstate();
//untransform variance variables
for(s = 0; s < nSamples; s++){
covTransInv(&REAL(samples_r)[s*nParams+AIndx], &REAL(samples_r)[s*nParams+AIndx], m);
if(nugget){
for(i = 0; i < m; i++){
REAL(samples_r)[s*nParams+PsiIndx+i] = exp(REAL(samples_r)[s*nParams+PsiIndx+i]);
}
}
for(i = 0; i < m; i++){
REAL(samples_r)[s*nParams+phiIndx+i] = logitInv(REAL(samples_r)[s*nParams+phiIndx+i], phiUnif[i*2], phiUnif[i*2+1]);
if(covModel == "matern"){
REAL(samples_r)[s*nParams+nuIndx+i] = logitInv(REAL(samples_r)[s*nParams+nuIndx+i], nuUnif[i*2], nuUnif[i*2+1]);
}
}
}
//make return object
SEXP result_r, resultName_r;
int nResultListObjs = 2;
if(amcmc){
nResultListObjs++;
}
PROTECT(result_r = allocVector(VECSXP, nResultListObjs)); nProtect++;
PROTECT(resultName_r = allocVector(VECSXP, nResultListObjs)); nProtect++;
//samples
SET_VECTOR_ELT(result_r, 0, samples_r);
SET_VECTOR_ELT(resultName_r, 0, mkChar("p.theta.samples"));
SET_VECTOR_ELT(result_r, 1, accept_r);
SET_VECTOR_ELT(resultName_r, 1, mkChar("acceptance"));
if(amcmc){
SET_VECTOR_ELT(result_r, 2, tuning_r);
SET_VECTOR_ELT(resultName_r, 2, mkChar("tuning"));
}
namesgets(result_r, resultName_r);
//unprotect
UNPROTECT(nProtect);
return(result_r);
}
SEXP R_point_in_polygon_sp(const SEXP px, const SEXP py, const SEXP polx,
const SEXP poly) {
int i, pc=0;
PLOT_POINT p;
POLYGON pol;
SEXP ret, px1, py1, polx1, poly1;
if (MAYBE_REFERENCED(px)) {
PROTECT(px1 = duplicate(px));
pc++;
} else
px1 = px;
if (MAYBE_REFERENCED(py)) {
PROTECT(py1 = duplicate(py));
pc++;
} else
py1 = py;
if (MAYBE_REFERENCED(polx)) {
PROTECT(polx1 = duplicate(polx));
pc++;
} else
polx1 = polx;
if (MAYBE_REFERENCED(poly)) {
PROTECT(poly1 = duplicate(poly));
pc++;
} else
poly1 = poly;
pol.lines = LENGTH(polx); /* check later that first == last */
pol.p = (PLOT_POINT *) R_alloc((size_t) pol.lines, sizeof(PLOT_POINT));
/* transient; will be freed by R; freed by R on user interrupt */
for (i = 0; i < LENGTH(polx); i++) {
pol.p[i].x = NUMERIC_POINTER(polx)[i];
pol.p[i].y = NUMERIC_POINTER(poly)[i];
}
pol.close = (pol.p[0].x == pol.p[pol.lines - 1].x &&
pol.p[0].y == pol.p[pol.lines - 1].y);
setup_poly_minmax(&pol);
PROTECT(ret = NEW_INTEGER(LENGTH(px))); pc++;
for (i = 0; i < LENGTH(px); i++) {
p.x = NUMERIC_POINTER(px)[i];
p.y = NUMERIC_POINTER(py)[i];
/*
For each query point q, InPoly returns one of four char's:
i : q is strictly interior to P
o : q is strictly exterior to P
v : q is a vertex of P
e : q lies on the relative interior of an edge of P
*/
switch (InPoly(p, &pol)) {
case 'i': INTEGER_POINTER(ret)[i] = 1; break;
case 'o': INTEGER_POINTER(ret)[i] = 0; break;
case 'v': INTEGER_POINTER(ret)[i] = 3; break;
case 'e': INTEGER_POINTER(ret)[i] = 2; break;
default: INTEGER_POINTER(ret)[i] = -1; break;
}
}
UNPROTECT(pc);
return(ret);
}