SEXP R_GAxisPars(SEXP usr, SEXP is_log, SEXP nintLog)
{
Rboolean logflag = asLogical(is_log);
int n = asInteger(nintLog);// will be changed on output ..
double min, max;
const char *nms[] = {"axp", "n", ""};
SEXP axp, ans;
usr = coerceVector(usr, REALSXP);
if(LENGTH(usr) != 2) error(_("'%s' must be numeric of length %d"), "usr", 2);
min = REAL(usr)[0];
max = REAL(usr)[1];
GAxisPars(&min, &max, &n, logflag, 0);// axis = 0 :<==> do not warn.. [TODO!]
// -> ../../../main/graphics.c
PROTECT(ans = mkNamed(VECSXP, nms));
SET_VECTOR_ELT(ans, 0, (axp = allocVector(REALSXP, 2)));// protected
SET_VECTOR_ELT(ans, 1, ScalarInteger(n));
REAL(axp)[0] = min;
REAL(axp)[1] = max;
UNPROTECT(1);
return ans;
}
SEXP R_invoked_C_glue(SEXP c_sym, SEXP context, SEXP x, SEXP compute_grad) {
// Identify the problem dimension and extract a function pointer
// for the log density.
int ndim = length(x);
log_density_t *log_dens_fn = *(log_density_t**)RAW(c_sym);
dist_t ds = { .log_dens=log_dens_fn, .context=context, .ndim=ndim };
if (*LOGICAL(compute_grad)) {
// Allocate a vector for the gradient and call the log density.
SEXP grad, result;
PROTECT( grad = allocVector(REALSXP, ndim) );
double y = log_dens_fn(&ds, REAL(x), 1, REAL(grad));
// Store the log density and gradient in a list and return it.
const char *result_names[] = { "log.density", "grad.log.density", "" };
PROTECT(result = mkNamed(VECSXP, result_names));
SET_VECTOR_ELT(result, 0, ScalarReal(y));
SET_VECTOR_ELT(result, 1, grad);
UNPROTECT(2);
return result;
} else {
// Call the log density function.
double y = log_dens_fn(&ds, REAL(x), 0, NULL);
// Store the log density in a list and return it.
SEXP result;
const char *result_names[] = { "log.density", "" };
PROTECT(result = mkNamed(VECSXP, result_names));
SET_VECTOR_ELT(result, 0, ScalarReal(y));
UNPROTECT(1);
return result;
}
}
SEXP sampler_glue_C_dist(
SEXP sampler_name, SEXP sampler_context, SEXP log_dens_name,
SEXP dist_context, SEXP x0, SEXP sample_size, SEXP tuning) {
// Locate symbol for sampler function.
const char *sampler_str = CHAR(STRING_ELT(sampler_name,0));
sampler_t *sampler_fp = (sampler_t*)R_FindSymbol(sampler_str, "", NULL);
if (sampler_fp==NULL)
error("Cannot locate symbol \"%s\".", sampler_str);
// Locate symbol for log density.
const char *log_dens_str = CHAR(STRING_ELT(log_dens_name,0));
log_density_t *log_dens_fp =
(log_density_t*)R_FindSymbol(log_dens_str, "", NULL);
if (log_dens_fp==NULL)
error("Cannot locate symbol \"%s\".", log_dens_str);
// Define a stub function to keep track of the number of function calls.
int ndim = length(x0);
C_stub_context_t stub_context =
{ .ds = { .log_dens=log_dens_fp, .ndim=ndim, .context=dist_context },
.evals=0, .grads=0 };
SEXP raw_context;
PROTECT(raw_context = void_as_raw(&stub_context));
dist_t stub_ds = { .log_dens=C_log_density_stub_func,
.context=raw_context, .ndim=ndim };
// Create a matrix to store the states in and call the sampler.
SEXP X;
PROTECT(X = allocMatrix(REALSXP, *REAL(sample_size), ndim));
GetRNGstate();
sampler_fp(sampler_context, &stub_ds, REAL(x0), *REAL(sample_size),
*REAL(tuning), REAL(X));
PutRNGstate();
// Construct the result to return.
const char *result_names[] = { "X", "evals", "grads", "" };
SEXP result;
PROTECT(result = mkNamed(VECSXP, result_names));
SET_VECTOR_ELT(result, 0, X);
SET_VECTOR_ELT(result, 1, ScalarInteger(stub_context.evals));
SET_VECTOR_ELT(result, 2, ScalarInteger(stub_context.grads));
UNPROTECT(3);
return result;
}
/*
* put some convergence-related information into list
*/
static SEXP
ConvInfoMsg(char* msg, int iter, int whystop, double fac,
double minFac, int maxIter, double convNew)
{
const char *nms[] = {"isConv", "finIter", "finTol",
"stopCode", "stopMessage", ""};
SEXP ans;
PROTECT(ans = mkNamed(VECSXP, nms));
SET_VECTOR_ELT(ans, 0, ScalarLogical(whystop == 0)); /* isConv */
SET_VECTOR_ELT(ans, 1, ScalarInteger(iter)); /* finIter */
SET_VECTOR_ELT(ans, 2, ScalarReal (convNew)); /* finTol */
SET_VECTOR_ELT(ans, 3, ScalarInteger(whystop)); /* stopCode */
SET_VECTOR_ELT(ans, 4, mkString(msg)); /* stopMessage */
UNPROTECT(1);
return ans;
}
SEXP isoreg(SEXP y)
{
int n = LENGTH(y), i, ip, known, n_ip;
double tmp, slope;
SEXP yc, yf, iKnots, ans;
const char *anms[] = {"y", "yc", "yf", "iKnots", ""};
/* unneeded: y = coerceVector(y, REALSXP); */
PROTECT(ans = mkNamed(VECSXP, anms));
SET_VECTOR_ELT(ans, 0, y);
SET_VECTOR_ELT(ans, 1, yc = allocVector(REALSXP, n+1));
SET_VECTOR_ELT(ans, 2, yf = allocVector(REALSXP, n));
SET_VECTOR_ELT(ans, 3, iKnots= allocVector(INTSXP, n));
/* yc := cumsum(0,y) */
REAL(yc)[0] = 0.;
tmp = 0.;
for (i = 0; i < n; i++) {
tmp += REAL(y)[i];
REAL(yc)[i + 1] = tmp;
}
known = 0; ip = 0, n_ip = 0;
do {
slope = R_PosInf;/*1e+200*/
for (i = known + 1; i <= n; i++) {
tmp = (REAL(yc)[i] - REAL(yc)[known]) / (i - known);
if (tmp < slope) {
slope = tmp;
ip = i;
}
}/* tmp := max{i= kn+1,.., n} slope(p[kn] -> p[i]) and
* ip = argmax{...}... */
INTEGER(iKnots)[n_ip++] = ip;
for (i = known; i < ip; i++)
REAL(yf)[i] = (REAL(yc)[ip] - REAL(yc)[known]) / (ip - known);
} while ((known = ip) < n);
if (n_ip < n)
SET_VECTOR_ELT(ans, 3, lengthgets(iKnots, n_ip));
UNPROTECT(1);
return(ans);
}
SEXP lspairdistla(SEXP(x), SEXP(y), SEXP(la))
{
const char *outnames[] = {"lsd", "eud", ""};
int n = length(x);
double *px, *py, *prola, *plsd, *peud;
double xi, yi, rolai, dx, dy, dd, ldd;
SEXP rola = PROTECT(duplicate(la));
SEXP out = PROTECT (mkNamed(VECSXP, outnames));
SEXP lsd = SET_VECTOR_ELT(out, 0, allocMatrix(REALSXP, n, n));
SEXP eud = SET_VECTOR_ELT(out, 1, allocMatrix(REALSXP, n, n));
px = REAL(x);
py = REAL(y);
prola = REAL(rola);
plsd = REAL(lsd);
peud = REAL(eud);
for(int i = 0; i < n; i++) {
prola[i] = sqrt(prola[i])/2;
}
for(int i = 0; i < n; i++) {
xi = px[i];
yi = py[i];
rolai = prola[i];
plsd[i * (n + 1)] = 0;
peud[i * (n + 1)] = 0;
for(int j = i+1; j < n; j++) {
dx = px[j] - xi;
dy = py[j] - yi;
dd = sqrt(dx * dx + dy * dy);
peud[i + n * j] = dd;
peud[j + n * i] = dd;
ldd = dd * (prola[j] + rolai);
plsd[i + n * j] = ldd;
plsd[j + n * i] = ldd;
}
}
UNPROTECT(2);
return(out);
}
SEXP isoreg(SEXP y)
{
int n = LENGTH(y), i, ip, known, n_ip;
double tmp, slope;
SEXP yc, yf, iKnots, ans;
const char *anms[] = {"y", "yf", ""};
double *yPAV;
/* unneeded: y = coerceVector(y, REALSXP); */
PROTECT(ans = mkNamed(VECSXP, anms));
SET_VECTOR_ELT(ans, 0, y);
SET_VECTOR_ELT(ans, 1, yf = allocVector(REALSXP, n));
PAV(REAL(y), n, REAL(yf));
UNPROTECT(1);
return(ans);
}
/* --- .Call ENTRY POINT --- */
SEXP BWGFile_query(SEXP r_filename, SEXP r_ranges, SEXP r_return_score,
SEXP r_return_list) {
pushRHandlers();
struct bbiFile * file = bigWigFileOpen((char *)CHAR(asChar(r_filename)));
SEXP chromNames = getAttrib(r_ranges, R_NamesSymbol);
int nchroms = length(r_ranges);
Rboolean return_list = asLogical(r_return_list);
SEXP rangesList, rangesListEls, dataFrameList, dataFrameListEls, ans;
SEXP numericListEls;
bool returnScore = asLogical(r_return_score);
const char *var_names[] = { "score", "" };
struct lm *lm = lmInit(0);
struct bbiInterval *hits = NULL;
struct bbiInterval *qhits = NULL;
if (return_list) {
int n_ranges = 0;
for(int i = 0; i < nchroms; i++) {
SEXP localRanges = VECTOR_ELT(r_ranges, i);
n_ranges += get_IRanges_length(localRanges);
}
PROTECT(numericListEls = allocVector(VECSXP, n_ranges));
} else {
PROTECT(rangesListEls = allocVector(VECSXP, nchroms));
setAttrib(rangesListEls, R_NamesSymbol, chromNames);
PROTECT(dataFrameListEls = allocVector(VECSXP, nchroms));
setAttrib(dataFrameListEls, R_NamesSymbol, chromNames);
}
int elt_len = 0;
for (int i = 0; i < nchroms; i++) {
SEXP localRanges = VECTOR_ELT(r_ranges, i);
int nranges = get_IRanges_length(localRanges);
int *start = INTEGER(get_IRanges_start(localRanges));
int *width = INTEGER(get_IRanges_width(localRanges));
for (int j = 0; j < nranges; j++) {
struct bbiInterval *queryHits =
bigWigIntervalQuery(file, (char *)CHAR(STRING_ELT(chromNames, i)),
start[j] - 1, start[j] - 1 + width[j], lm);
/* IntegerList */
if (return_list) {
qhits = queryHits;
int nqhits = slCount(queryHits);
SEXP ans_numeric;
PROTECT(ans_numeric = allocVector(REALSXP, width[j]));
memset(REAL(ans_numeric), 0, sizeof(double) * width[j]);
for (int k = 0; k < nqhits; k++, qhits = qhits->next) {
for (int l = qhits->start; l < qhits->end; l++)
REAL(ans_numeric)[(l - start[j] + 1)] = qhits->val;
}
SET_VECTOR_ELT(numericListEls, elt_len, ans_numeric);
elt_len++;
UNPROTECT(1);
}
slReverse(&queryHits);
hits = slCat(queryHits, hits);
}
/* RangedData */
if (!return_list) {
int nhits = slCount(hits);
slReverse(&hits);
SEXP ans_start, ans_width, ans_score, ans_score_l;
PROTECT(ans_start = allocVector(INTSXP, nhits));
PROTECT(ans_width = allocVector(INTSXP, nhits));
if (returnScore) {
PROTECT(ans_score_l = mkNamed(VECSXP, var_names));
ans_score = allocVector(REALSXP, nhits);
SET_VECTOR_ELT(ans_score_l, 0, ans_score);
} else {
PROTECT(ans_score_l = mkNamed(VECSXP, var_names + 1));
}
for (int j = 0; j < nhits; j++, hits = hits->next) {
INTEGER(ans_start)[j] = hits->start + 1;
INTEGER(ans_width)[j] = hits->end - hits->start;
if (returnScore)
REAL(ans_score)[j] = hits->val;
}
SET_VECTOR_ELT(rangesListEls, i,
new_IRanges("IRanges", ans_start, ans_width, R_NilValue));
SET_VECTOR_ELT(dataFrameListEls, i,
new_DataFrame("DataFrame", ans_score_l, R_NilValue,
ScalarInteger(nhits)));
UNPROTECT(3);
}
}
bbiFileClose(&file);
if (return_list) {
ans = new_SimpleList("SimpleList", numericListEls);
UNPROTECT(1);
} else {
PROTECT(dataFrameList =
new_SimpleList("SimpleSplitDataFrameList", dataFrameListEls));
PROTECT(rangesList = new_SimpleList("SimpleRangesList", rangesListEls));
ans = new_RangedData("RangedData", rangesList, dataFrameList);
UNPROTECT(4);
}
lmCleanup(&lm);
popRHandlers();
return ans;
}
SEXP survfitci(SEXP ftime2, SEXP sort12, SEXP sort22, SEXP ntime2,
SEXP status2, SEXP cstate2, SEXP wt2, SEXP id2,
SEXP p2, SEXP sefit2) {
int i, j, k, kk; /* generic loop indices */
int ck, itime, eptr; /*specific indices */
int ctime; /*current time of interest, in the main loop */
int nprotect; /* number of protect calls issued */
int oldstate, newstate; /*when changing state */
double temp, *temp2; /* scratch */
double *p; /* current prevalence vector */
double **hmat; /* hazard matrix at this time point */
double **umat; /* per subject leverage at this time point */
int *atrisk; /* 1 if the subject is currently at risk */
int *ns; /* number curently in each state */
double *ws; /* weighted count of number state */
double *wtp; /* case weights indexed by subject */
double wevent; /* weighted number of events at current time */
int nstate; /* number of states */
int n, nperson; /*number of obs, subjects*/
double **chaz; /* cumulative hazard matrix */
/* pointers to the R variables */
int *sort1, *sort2; /*sort index for entry time, event time */
int *entry,* etime; /*entry time, event time */
int ntime; /* number of unique event time values */
int *status; /*0=censored, 1,2,... new states */
int *cstate; /* current state for each subject */
double *wt; /* weight for each observation */
int *id; /* for each obs, which subject is it */
int sefit;
/* returned objects */
SEXP rlist; /* the returned list and variable names of same */
const char *rnames[]= {"nrisk","nevent","ncensor", "prev",
"cumhaz", "var", ""};
SEXP pmat2, vmat2, cumhaz2; /*list components */
SEXP nevent2, ncensor2, nrisk2;
double *pmat, *vmat, *cumhaz;
int *ncensor, *nrisk, *nevent;
ntime= asInteger(ntime2);
nperson = LENGTH(cstate2);
n = LENGTH(sort12);
PROTECT(cstate2 = duplicate(cstate2));
cstate = INTEGER(cstate2);
entry= INTEGER(ftime2);
etime= entry + n;
sort1= INTEGER(sort12);
sort2= INTEGER(sort22);
status= INTEGER(status2);
wt = REAL(wt2);
id = INTEGER(id2);
PROTECT(p2 = duplicate(p2)); /*copy of initial prevalence */
p = REAL(p2);
nstate = LENGTH(p2); /* number of states */
sefit = asInteger(sefit2);
/* allocate space for the output objects */
PROTECT(pmat2 = allocMatrix(REALSXP, nstate, ntime));
pmat = REAL(pmat2);
if (sefit >0)
PROTECT(vmat2 = allocMatrix(REALSXP, nstate, ntime));
else PROTECT(vmat2 = allocMatrix(REALSXP, 1, 1)); /* dummy object */
vmat = REAL(vmat2);
PROTECT(nevent2 = allocVector(INTSXP, ntime));
nevent = INTEGER(nevent2);
PROTECT(ncensor2= allocVector(INTSXP, ntime));
ncensor = INTEGER(ncensor2);
PROTECT(nrisk2 = allocMatrix(INTSXP, nstate, ntime));
nrisk = INTEGER(nrisk2);
PROTECT(cumhaz2= allocVector(REALSXP, nstate*nstate*ntime));
cumhaz = REAL(cumhaz2);
nprotect = 8;
/* allocate space for scratch vectors */
ws = (double *) R_alloc(2*nstate, sizeof(double));
temp2 = ws + nstate;
ns = (int *) R_alloc(nstate, sizeof(int));
atrisk = (int *) R_alloc(nperson, sizeof(int));
wtp = (double *) R_alloc(nperson, sizeof(double));
hmat = (double**) dmatrix2(nstate, nstate);
if (sefit >0) umat = (double**) dmatrix2(nperson, nstate);
chaz = (double**) dmatrix2(nstate, nstate);
/* R_alloc does not zero allocated memory */
for (i=0; i<nstate; i++) {
ws[i] =0;
ns[i] =0;
for (j=0; j<nstate; j++) {
hmat[i][j] =0;
chaz[i][j] =0;
}
if (sefit) {for (j=0; j<nperson; j++) umat[j][i]=0;}
}
for (i=0; i<nperson; i++) atrisk[i] =0;
itime =0; /*current time index, for output arrays */
eptr = 0; /*index to sort1, the entry times */
for (i=0; i<n; ) {
ck = sort2[i];
ctime = etime[ck]; /* current time value of interest */
/* Add subjects whose entry time is < ctime into the counts */
for (; eptr<n; eptr++) {
k = sort1[eptr];
if (entry[k] < ctime) {
kk = cstate[id[k]]; /*current state of the addition */
ns[kk]++;
ws[kk] += wt[k];
wtp[id[k]] = wt[k];
atrisk[id[k]] =1; /* mark them as being at risk */
}
else break;
}
for (j=0; j<nstate; j++) {
for (k=0; k<nstate; k++) {
hmat[j][k] =0;
}
}
/* Count up the number of events and censored at this time point */
nevent[itime] =0;
ncensor[itime] =0;
wevent =0;
for (j=i; j<n; j++) {
k = sort2[j];
if (etime[k] == ctime) {
if (status[k] >0) {
newstate = status[k] -1; /* 0 based subscripts */
oldstate = cstate[id[k]];
nevent[itime]++;
wevent += wt[k];
hmat[oldstate][newstate] += wt[k];
}
else ncensor[itime]++;
}
else break;
}
if (nevent[itime]> 0) {
/* finish computing H */
for (j=0; j<nstate; j++) {
if (ns[j] >0) {
temp =0;
for (k=0; k<nstate; k++) {
temp += hmat[j][k];
hmat[j][k] /= ws[j]; /* events/n */
}
hmat[j][j] =1 -temp/ws[j]; /*rows sum to one */
}
else hmat[j][j] =1.0;
}
if (sefit >0) {
/* Update U, part 1 U = U %*% H -- matrix multiplication */
for (j=0; j<nperson; j++) { /* row of U */
for (k=0; k<nstate; k++) { /* column of U */
temp2[k]=0;
for (kk=0; kk<nstate; kk++)
temp2[k] += umat[j][kk] * hmat[kk][k];
}
for (k=0; k<nstate; k++) umat[j][k] = temp2[k];
}
/* Update U, part 2, subtract from everyone at risk
For this I need H2 */
for (j=0; j<nstate; j++) hmat[j][j] -= 1;
for (j=0; j<nperson; j++) {
if (atrisk[j]==1) {
kk = cstate[j];
for (k=0; k<nstate; k++)
umat[j][k] -= (p[kk]/ws[kk])* hmat[kk][k];
}
}
/* Update U, part 3. An addition for each event */
for (j=i; j<n; j++) {
k = sort2[j];
if (etime[k] == ctime) {
if (status[k] >0) {
kk = id[k]; /* row number in U */
oldstate= cstate[kk];
newstate= status[k] -1;
umat[kk][oldstate] -= p[oldstate]/ws[oldstate];
umat[kk][newstate] += p[oldstate]/ws[oldstate];
}
}
else break;
}
}
/* Finally, update chaz and p. */
for (j=0; j<nstate; j++) {
if (sefit ==0) hmat[j][j] -= 1; /* conversion to H2*/
for (k=0; k<nstate; k++) chaz[j][k] += hmat[j][k];
hmat[j][j] +=1; /* change from H2 to H */
temp2[j] =0;
for (k=0; k<nstate; k++)
temp2[j] += p[k] * hmat[k][j];
}
for (j=0; j<nstate; j++) p[j] = temp2[j];
}
/* store into the matrices that will be passed back */
for (j=0; j<nstate; j++) {
*pmat++ = p[j];
*nrisk++ = ns[j];
for (k=0; k<nstate; k++) *cumhaz++ = chaz[k][j];
temp=0;
if (sefit >0) {
for (k=0; k<nperson; k++)
temp += wtp[k]* umat[k][j]*umat[k][j];
*vmat++ = temp;
}
}
/* Take the current events and censors out of the risk set */
for (; i<n; i++) {
j= sort2[i];
if (etime[j] == ctime) {
oldstate = cstate[id[j]]; /*current state */
ns[oldstate]--;
ws[oldstate] -= wt[j];
if (status[j] >0) cstate[id[j]] = status[j]-1; /*new state */
atrisk[id[j]] =0;
}
else break;
}
itime++;
}
/* return a list */
PROTECT(rlist=mkNamed(VECSXP, rnames));
SET_VECTOR_ELT(rlist, 0, nrisk2);
SET_VECTOR_ELT(rlist, 1, nevent2);
SET_VECTOR_ELT(rlist, 2, ncensor2);
SET_VECTOR_ELT(rlist, 3, pmat2);
SET_VECTOR_ELT(rlist, 4, cumhaz2);
SET_VECTOR_ELT(rlist, 5, vmat2);
UNPROTECT(nprotect +1);
return(rlist);
}
SEXP Cdqrls(SEXP x, SEXP y, SEXP tol, SEXP chk)
{
SEXP ans;
SEXP qr, coefficients, residuals, effects, pivot, qraux;
int n, ny = 0, p, rank, nprotect = 4, pivoted = 0;
double rtol = asReal(tol), *work;
Rboolean check = asLogical(chk);
ans = getDimAttrib(x);
if(check && length(ans) != 2) error(_("'x' is not a matrix"));
int *dims = INTEGER(ans);
n = dims[0]; p = dims[1];
if(n) ny = (int)(XLENGTH(y)/n); /* y : n x ny, or an n - vector */
if(check && n * ny != XLENGTH(y))
error(_("dimensions of 'x' (%d,%d) and 'y' (%d) do not match"),
n,p, XLENGTH(y));
/* These lose attributes, so do after we have extracted dims */
if (TYPEOF(x) != REALSXP) {
PROTECT(x = coerceVector(x, REALSXP));
nprotect++;
}
if (TYPEOF(y) != REALSXP) {
PROTECT(y = coerceVector(y, REALSXP));
nprotect++;
}
double *rptr = REAL(x);
for (R_xlen_t i = 0 ; i < XLENGTH(x) ; i++)
if(!R_FINITE(rptr[i])) error(_("NA/NaN/Inf in '%s'"), "x");
rptr = REAL(y);
for (R_xlen_t i = 0 ; i < XLENGTH(y) ; i++)
if(!R_FINITE(rptr[i])) error(_("NA/NaN/Inf in '%s'"), "y");
const char *ansNms[] = {"qr", "coefficients", "residuals", "effects",
"rank", "pivot", "qraux", "tol", "pivoted", ""};
PROTECT(ans = mkNamed(VECSXP, ansNms));
SET_VECTOR_ELT(ans, 0, qr = duplicate(x));
coefficients = (ny > 1) ? allocMatrix(REALSXP, p, ny) : allocVector(REALSXP, p);
PROTECT(coefficients);
SET_VECTOR_ELT(ans, 1, coefficients);
SET_VECTOR_ELT(ans, 2, residuals = duplicate(y));
SET_VECTOR_ELT(ans, 3, effects = duplicate(y));
PROTECT(pivot = allocVector(INTSXP, p));
int *ip = INTEGER(pivot);
for(int i = 0; i < p; i++) ip[i] = i+1;
SET_VECTOR_ELT(ans, 5, pivot);
PROTECT(qraux = allocVector(REALSXP, p));
SET_VECTOR_ELT(ans, 6, qraux);
SET_VECTOR_ELT(ans, 7, tol);
work = (double *) R_alloc(2 * p, sizeof(double));
F77_CALL(dqrls)(REAL(qr), &n, &p, REAL(y), &ny, &rtol,
REAL(coefficients), REAL(residuals), REAL(effects),
&rank, INTEGER(pivot), REAL(qraux), work);
SET_VECTOR_ELT(ans, 4, ScalarInteger(rank));
for(int i = 0; i < p; i++)
if(ip[i] != i+1) { pivoted = 1; break; }
SET_VECTOR_ELT(ans, 8, ScalarLogical(pivoted));
UNPROTECT(nprotect);
return ans;
}
SEXP concordance3(SEXP y, SEXP x2, SEXP wt2, SEXP timewt2,
SEXP sortstop, SEXP doresid2) {
int i, j, k, ii, jj, kk, j2;
int n, ntree, nevent;
double *time, *status;
int xsave;
/* sum of weights for a node (nwt), sum of weights for the node and
** all of its children (twt), then the same again for the subset of
** deaths
*/
double *nwt, *twt, *dnwt, *dtwt;
double z2; /* sum of z^2 values */
int ndeath; /* total number of deaths at this point */
int utime; /* number of unique event times seen so far */
double dwt, dwt2; /* sum of weights for deaths and deaths tied on x */
double wsum[3]; /* the sum of weights that are > current, <, or equal */
double temp, adjtimewt; /* the second accounts for npair and timewt*/
SEXP rlist, count2, imat2, resid2;
double *count, *imat[5], *resid[4];
double *wt, *timewt;
int *x, *sort2;
int doresid;
static const char *outnames1[]={"count", "influence", "resid", ""},
*outnames2[]={"count", "influence", ""};
n = nrows(y);
doresid = asLogical(doresid2);
x = INTEGER(x2);
wt = REAL(wt2);
timewt = REAL(timewt2);
sort2 = INTEGER(sortstop);
time = REAL(y);
status = time + n;
/* if there are tied predictors, the total size of the tree will be < n */
ntree =0; nevent =0;
for (i=0; i<n; i++) {
if (x[i] >= ntree) ntree = x[i] +1;
nevent += status[i];
}
nwt = (double *) R_alloc(4*ntree, sizeof(double));
twt = nwt + ntree;
dnwt = twt + ntree;
dtwt = dnwt + ntree;
for (i=0; i< 4*ntree; i++) nwt[i] =0.0;
if (doresid) PROTECT(rlist = mkNamed(VECSXP, outnames1));
else PROTECT(rlist = mkNamed(VECSXP, outnames2));
count2 = SET_VECTOR_ELT(rlist, 0, allocVector(REALSXP, 6));
count = REAL(count2);
for (i=0; i<6; i++) count[i]=0.0;
imat2 = SET_VECTOR_ELT(rlist, 1, allocMatrix(REALSXP, n, 5));
for (i=0; i<5; i++) {
imat[i] = REAL(imat2) + i*n;
for (j=0; j<n; j++) imat[i][j] =0;
}
if (doresid==1) {
resid2 = SET_VECTOR_ELT(rlist, 2, allocMatrix(REALSXP, nevent, 4));
for (i=0; i<4; i++) resid[i] = REAL(resid2) + i*nevent;
}
z2 =0; utime=0;
for (i=0; i<n;) {
ii = sort2[i];
if (status[ii]==0) { /* censored, simply add them into the tree */
/* Initialize the influence */
walkup(dnwt, dtwt, x[ii], wsum, ntree);
imat[0][ii] -= wsum[1];
imat[1][ii] -= wsum[0];
imat[2][ii] -= wsum[2];
/* Cox variance */
walkup(nwt, twt, x[ii], wsum, ntree);
z2 += wt[ii]*(wsum[0]*(wt[ii] + 2*(wsum[1] + wsum[2])) +
wsum[1]*(wt[ii] + 2*(wsum[0] + wsum[2])) +
(wsum[0]-wsum[1])*(wsum[0]-wsum[1]));
/* add them to the tree */
addin(nwt, twt, x[ii], wt[ii]);
i++;
}
else { /* process all tied deaths at this point */
ndeath=0; dwt=0;
dwt2 =0; xsave=x[ii]; j2= i;
adjtimewt = timewt[utime++];
/* pass 1 */
for (j=i; j<n && time[sort2[j]]==time[ii]; j++) {
jj = sort2[j];
ndeath++;
count[3] += wt[jj] * dwt * adjtimewt; /* update total tied on y */
dwt += wt[jj]; /* sum of wts at this death time */
if (x[jj] != xsave) { /* restart the tied.xy counts */
if (wt[sort2[j2]] < dwt2) { /* more than 1 tied */
for (; j2<j; j2++) {
/* update influence for this subgroup of x */
kk = sort2[j2];
imat[4][kk] += (dwt2- wt[kk]) * adjtimewt;
imat[3][kk] -= (dwt2- wt[kk]) * adjtimewt;
}
} else j2 = j;
dwt2 =0;
xsave = x[jj];
}
count[4] += wt[jj] * dwt2 * adjtimewt; /* tied on xy */
dwt2 += wt[jj]; /* sum of tied.xy weights */
/* Count concordant, discordant, etc. */
walkup(nwt, twt, x[jj], wsum, ntree);
for (k=0; k<3; k++) {
count[k] += wt[jj]* wsum[k] * adjtimewt;
imat[k][jj] += wsum[k]*adjtimewt;
}
/* add to the event tree */
addin(dnwt, dtwt, x[jj], adjtimewt*wt[jj]); /* weighted deaths */
/* first part of residuals */
if (doresid) {
nevent--;
resid[0][nevent] = (wsum[0] - wsum[1])/twt[0]; /* -1 to 1 */
resid[1][nevent] = twt[0] * adjtimewt;
resid[2][nevent] = wt[jj];
}
}
/* finish the tied.xy influence */
if (wt[sort2[j2]] < dwt2) { /* more than 1 tied */
for (; j2<j; j2++) {
/* update influence for this subgroup of x */
kk = sort2[j2];
imat[4][kk] += (dwt2- wt[kk]) * adjtimewt;
imat[3][kk] -= (dwt2- wt[kk]) * adjtimewt;
}
}
/* pass 2 */
for (j=i; j< (i+ndeath); j++) {
jj = sort2[j];
/* Update influence */
walkup(dnwt, dtwt, x[jj], wsum, ntree);
imat[0][jj] -= wsum[1];
imat[1][jj] -= wsum[0];
imat[2][jj] -= wsum[2]; /* tied.x */
imat[3][jj] += (dwt- wt[jj])* adjtimewt;
/* increment Cox var and add obs into the tree */
walkup(nwt, twt, x[jj], wsum, ntree);
z2 += wt[jj]*(wsum[0]*(wt[jj] + 2*(wsum[1] + wsum[2])) +
wsum[1]*(wt[jj] + 2*(wsum[0] + wsum[2])) +
(wsum[0]-wsum[1])*(wsum[0]-wsum[1]));
addin(nwt, twt, x[jj], wt[jj]);
}
count[5] += dwt * adjtimewt* z2/twt[0]; /* weighted var in risk set*/
i += ndeath;
if (doresid) { /*Add the last part of the residuals */
temp = twt[0]*twt[0]*twt[0];
for (j=0; j<ndeath; j++)
resid[3][nevent+j] = z2/temp;
}
}
}
/*
** Now finish off the influence for each observation
** Since times flip (looking backwards) the wsum contributions flip too
*/
for (i=0; i<n; i++) {
ii = sort2[i];
walkup(dnwt, dtwt, x[ii], wsum, ntree);
imat[0][ii] += wsum[1];
imat[1][ii] += wsum[0];
imat[2][ii] += wsum[2];
}
count[3] -= count[4]; /* the tied.xy were counted twice, once as tied.y */
UNPROTECT(1);
return(rlist);
}
SEXP DEoptimC(SEXP lower, SEXP upper, SEXP fn, SEXP control, SEXP rho, SEXP fnMap)
{
int i, j, P=0;
if (!isFunction(fn))
error("fn is not a function!");
if (!isEnvironment(rho))
error("rho is not an environment!");
/*-----Initialization of annealing parameters-------------------------*/
/* value to reach */
double VTR = NUMERIC_VALUE(getListElement(control, "VTR"));
/* chooses DE-strategy */
int i_strategy = INTEGER_VALUE(getListElement(control, "strategy"));
/* Maximum number of generations */
int i_itermax = INTEGER_VALUE(getListElement(control, "itermax"));
/* Dimension of parameter vector */
int i_D = INTEGER_VALUE(getListElement(control, "npar"));
/* Number of population members */
int i_NP = INTEGER_VALUE(getListElement(control, "NP"));
/* When to start storing populations */
int i_storepopfrom = INTEGER_VALUE(getListElement(control, "storepopfrom"))-1;
/* How often to store populations */
int i_storepopfreq = INTEGER_VALUE(getListElement(control, "storepopfreq"));
/* User-defined inital population */
int i_specinitialpop = INTEGER_VALUE(getListElement(control, "specinitialpop"));
double *initialpopv = NUMERIC_POINTER(getListElement(control, "initialpop"));
/* stepsize */
double d_weight = NUMERIC_VALUE(getListElement(control, "F"));
/* crossover probability */
double d_cross = NUMERIC_VALUE(getListElement(control, "CR"));
/* Best of parent and child */
int i_bs_flag = NUMERIC_VALUE(getListElement(control, "bs"));
/* Print progress? */
int i_trace = NUMERIC_VALUE(getListElement(control, "trace"));
/* p to define the top 100p% best solutions */
double d_pPct = NUMERIC_VALUE(getListElement(control, "p"));
/* crossover adaptation (a positive constant between 0 and 1) */
double d_c = NUMERIC_VALUE(getListElement(control, "c"));
/* relative tolerance */
double d_reltol = NUMERIC_VALUE(getListElement(control, "reltol"));
/* relative tolerance steps */
int i_steptol = NUMERIC_VALUE(getListElement(control, "steptol"));
int i_nstorepop = ceil((i_itermax - i_storepopfrom) / i_storepopfreq);
/* Use S_alloc, since it initializes with zeros FIXME: these should be SEXP */
double *gd_storepop = (double *)S_alloc(i_NP,sizeof(double) * i_D * i_nstorepop);
/* External pointers to return to R */
SEXP sexp_bestmem, sexp_bestval, sexp_nfeval, sexp_iter,
out, sexp_pop, sexp_storepop, sexp_bestmemit, sexp_bestvalit;
PROTECT(sexp_bestmem = NEW_NUMERIC(i_D)); P++;
PROTECT(sexp_pop = allocMatrix(REALSXP, i_D, i_NP)); P++;
PROTECT(sexp_bestmemit = allocMatrix(REALSXP, i_itermax, i_D)); P++;
PROTECT(sexp_bestvalit = allocVector(REALSXP, i_itermax)); P++;
double *gt_bestP = REAL(sexp_bestmem);
double *gd_pop = REAL(sexp_pop);
double *gd_bestmemit = REAL(sexp_bestmemit);
double *gd_bestvalit = REAL(sexp_bestvalit);
/* ensure lower and upper are double */
if(TYPEOF(lower) != REALSXP) {PROTECT(lower = coerceVector(lower, REALSXP)); P++;}
if(TYPEOF(upper) != REALSXP) {PROTECT(upper = coerceVector(upper, REALSXP)); P++;}
double *d_lower = REAL(lower);
double *d_upper = REAL(upper);
double gt_bestC;
int gi_iter = 0;
long l_nfeval = 0;
/*---optimization--------------------------------------*/
devol(VTR, d_weight, d_cross, i_bs_flag, d_lower, d_upper, fn, rho, i_trace,
i_strategy, i_D, i_NP, i_itermax,
initialpopv, i_storepopfrom, i_storepopfreq,
i_specinitialpop,
gt_bestP, >_bestC,
gd_pop, gd_storepop, gd_bestmemit, gd_bestvalit,
&gi_iter, d_pPct, d_c, &l_nfeval,
d_reltol, i_steptol, fnMap);
/*---end optimization----------------------------------*/
j = i_nstorepop * i_NP * i_D;
PROTECT(sexp_storepop = NEW_NUMERIC(j)); P++;
for (i = 0; i < j; i++)
NUMERIC_POINTER(sexp_storepop)[i] = gd_storepop[i];
PROTECT(sexp_nfeval = ScalarInteger(l_nfeval)); P++;
PROTECT(sexp_iter = ScalarInteger(gi_iter)); P++;
PROTECT(sexp_bestval = ScalarReal(gt_bestC)); P++;
const char *out_names[] = {"bestmem", "bestval", "nfeval",
"iter", "bestmemit", "bestvalit", "pop", "storepop", ""};
PROTECT(out = mkNamed(VECSXP, out_names)); P++;
SET_VECTOR_ELT(out, 0, sexp_bestmem);
SET_VECTOR_ELT(out, 1, sexp_bestval);
SET_VECTOR_ELT(out, 2, sexp_nfeval);
SET_VECTOR_ELT(out, 3, sexp_iter);
SET_VECTOR_ELT(out, 4, sexp_bestmemit);
SET_VECTOR_ELT(out, 5, sexp_bestvalit);
SET_VECTOR_ELT(out, 6, sexp_pop);
SET_VECTOR_ELT(out, 7, sexp_storepop);
UNPROTECT(P);
return out;
}
