SEXP port_nlminb(SEXP fn, SEXP gr, SEXP hs, SEXP rho,
SEXP lowerb, SEXP upperb, SEXP d, SEXP iv, SEXP v)
{
int i, n = LENGTH(d);
SEXP xpt;
SEXP dot_par_symbol = install(".par");
double *b = (double *) NULL, *g = (double *) NULL,
*h = (double *) NULL, fx = R_PosInf;
if (isNull(rho)) {
error(_("use of NULL environment is defunct"));
rho = R_BaseEnv;
} else
if (!isEnvironment(rho))
error(_("'rho' must be an environment"));
if (!isReal(d) || n < 1)
error(_("'d' must be a nonempty numeric vector"));
if (hs != R_NilValue && gr == R_NilValue)
error(_("When Hessian defined must also have gradient defined"));
if (R_NilValue == (xpt = findVarInFrame(rho, dot_par_symbol)) ||
!isReal(xpt) || LENGTH(xpt) != n)
error(_("environment 'rho' must contain a numeric vector '.par' of length %d"),
n);
/* We are going to alter .par, so must duplicate it */
defineVar(dot_par_symbol, duplicate(xpt), rho);
PROTECT(xpt = findVarInFrame(rho, dot_par_symbol));
if ((LENGTH(lowerb) == n) && (LENGTH(upperb) == n)) {
if (isReal(lowerb) && isReal(upperb)) {
double *rl=REAL(lowerb), *ru=REAL(upperb);
b = (double *)R_alloc(2*n, sizeof(double));
for (i = 0; i < n; i++) {
b[2*i] = rl[i];
b[2*i + 1] = ru[i];
}
} else error(_("'lower' and 'upper' must be numeric vectors"));
}
if (gr != R_NilValue) {
g = (double *)R_alloc(n, sizeof(double));
if (hs != R_NilValue)
h = (double *)R_alloc((n * (n + 1))/2, sizeof(double));
}
do {
nlminb_iterate(b, REAL(d), fx, g, h, INTEGER(iv), LENGTH(iv),
LENGTH(v), n, REAL(v), REAL(xpt));
if (INTEGER(iv)[0] == 2 && g) check_gv(gr, hs, rho, n, g, h);
else {
fx = asReal(eval(fn, rho));
if (ISNAN(fx)) {
warning("NA/NaN function evaluation");
fx = R_PosInf;
}
}
/* duplicate .par value again in case a callback has stored
value (package varComp does this) */
defineVar(dot_par_symbol, duplicate(xpt), rho);
xpt = findVarInFrame(rho, dot_par_symbol);
UNPROTECT(1);
PROTECT(xpt);
} while(INTEGER(iv)[0] < 3);
UNPROTECT(1); /* xpt */
return R_NilValue;
}
SEXP lapack_qr(SEXP Xin, SEXP tl)
{
SEXP ans, Givens, Gcpy, nms, pivot, qraux, X;
int i, n, nGivens = 0, p, trsz, *Xdims, rank;
double rcond = 0., tol = asReal(tl), *work;
if (!(isReal(Xin) & isMatrix(Xin)))
error(_("X must be a real (numeric) matrix"));
if (tol < 0.) error(_("tol, given as %g, must be non-negative"), tol);
if (tol > 1.) error(_("tol, given as %g, must be <= 1"), tol);
ans = PROTECT(allocVector(VECSXP,5));
SET_VECTOR_ELT(ans, 0, X = duplicate(Xin));
Xdims = INTEGER(coerceVector(getAttrib(X, R_DimSymbol), INTSXP));
n = Xdims[0]; p = Xdims[1];
SET_VECTOR_ELT(ans, 2, qraux = allocVector(REALSXP, (n < p) ? n : p));
SET_VECTOR_ELT(ans, 3, pivot = allocVector(INTSXP, p));
for (i = 0; i < p; i++) INTEGER(pivot)[i] = i + 1;
trsz = (n < p) ? n : p; /* size of triangular part of decomposition */
rank = trsz;
Givens = PROTECT(allocVector(VECSXP, rank - 1));
setAttrib(ans, R_NamesSymbol, nms = allocVector(STRSXP, 5));
SET_STRING_ELT(nms, 0, mkChar("qr"));
SET_STRING_ELT(nms, 1, mkChar("rank"));
SET_STRING_ELT(nms, 2, mkChar("qraux"));
SET_STRING_ELT(nms, 3, mkChar("pivot"));
SET_STRING_ELT(nms, 4, mkChar("Givens"));
if (n > 0 && p > 0) {
int info, *iwork, lwork;
double *xpt = REAL(X), tmp;
lwork = -1;
F77_CALL(dgeqrf)(&n, &p, xpt, &n, REAL(qraux), &tmp, &lwork, &info);
if (info)
error(_("First call to dgeqrf returned error code %d"), info);
lwork = (int) tmp;
work = (double *) R_alloc((lwork < 3*trsz) ? 3*trsz : lwork,
sizeof(double));
F77_CALL(dgeqrf)(&n, &p, xpt, &n, REAL(qraux), work, &lwork, &info);
if (info)
error(_("Second call to dgeqrf returned error code %d"), info);
iwork = (int *) R_alloc(trsz, sizeof(int));
F77_CALL(dtrcon)("1", "U", "N", &rank, xpt, &n, &rcond,
work, iwork, &info);
if (info)
error(_("Lapack routine dtrcon returned error code %d"), info);
while (rcond < tol) { /* check diagonal elements */
double minabs = (xpt[0] < 0.) ? -xpt[0]: xpt[0];
int jmin = 0;
for (i = 1; i < rank; i++) {
double el = xpt[i*(n+1)];
el = (el < 0.) ? -el: el;
if (el < minabs) {
jmin = i;
minabs = el;
}
}
if (jmin < (rank - 1)) {
SET_VECTOR_ELT(Givens, nGivens, getGivens(xpt, n, jmin, rank));
nGivens++;
}
rank--;
F77_CALL(dtrcon)("1", "U", "N", &rank, xpt, &n, &rcond,
work, iwork, &info);
if (info)
error(_("Lapack routine dtrcon returned error code %d"), info);
}
}
SET_VECTOR_ELT(ans, 4, Gcpy = allocVector(VECSXP, nGivens));
for (i = 0; i < nGivens; i++)
SET_VECTOR_ELT(Gcpy, i, VECTOR_ELT(Givens, i));
SET_VECTOR_ELT(ans, 1, ScalarInteger(rank));
setAttrib(ans, install("useLAPACK"), ScalarLogical(1));
setAttrib(ans, install("rcond"), ScalarReal(rcond));
UNPROTECT(2);
return ans;
}
SEXP firstCross(SEXP x, SEXP th, SEXP rel, SEXP start)
{
int i, int_rel, int_start, P=0;
double *real_x=NULL, real_th;
if(ncols(x) > 1)
error("only univariate data allowed");
/* this currently only works for real x and th arguments
* support for other types may be added later */
PROTECT(x = coerceVector(x, REALSXP)); P++;
real_th = asReal(th);
int_rel = asInteger(rel);
int_start = asInteger(start)-1;
/* return number of observations if relationship is never TRUE */
SEXP result = ScalarInteger(nrows(x));
switch(int_rel) {
case 1: /* > */
real_x = REAL(x);
for(i=int_start; i<nrows(x); i++)
if(real_x[i] > real_th) {
result = ScalarInteger(i+1);
break;
}
break;
case 2: /* < */
real_x = REAL(x);
for(i=int_start; i<nrows(x); i++)
if(real_x[i] < real_th) {
result = ScalarInteger(i+1);
break;
}
break;
case 3: /* == */
real_x = REAL(x);
for(i=int_start; i<nrows(x); i++)
if(real_x[i] == real_th) {
result = ScalarInteger(i+1);
break;
}
break;
case 4: /* >= */
real_x = REAL(x);
for(i=int_start; i<nrows(x); i++)
if(real_x[i] >= real_th) {
result = ScalarInteger(i+1);
break;
}
break;
case 5: /* <= */
real_x = REAL(x);
for(i=int_start; i<nrows(x); i++)
if(real_x[i] <= real_th) {
result = ScalarInteger(i+1);
break;
}
break;
default:
error("unsupported relationship operator");
}
UNPROTECT(P);
return(result);
}
SEXP na_locf_col (SEXP x, SEXP fromLast, SEXP _maxgap, SEXP _limit)
{
/* version of na_locf that works on multivariate data
* of type LGLSXP, INTSXP and REALSXP. */
SEXP result;
int i, ii, j, nr, nc, _first=0, P=0;
double gap, maxgap, limit;
int *int_x=NULL, *int_result=NULL;
double *real_x=NULL, *real_result=NULL;
nr = nrows(x);
nc = ncols(x);
maxgap = asReal(_maxgap);
limit = asReal(_limit);
gap = 0;
if(firstNonNA(x) == nr)
return(x);
PROTECT(result = allocMatrix(TYPEOF(x), nr, nc)); P++;
switch(TYPEOF(x)) {
case LGLSXP:
int_x = LOGICAL(x);
int_result = LOGICAL(result);
if(!LOGICAL(fromLast)[0]) {
for(j=0; j < nc; j++) {
/* copy leading NAs */
_first = firstNonNACol(x, j);
//if(_first+1 == nr) continue;
for(i=0+j*nr; i < (_first+1); i++) {
int_result[i] = int_x[i];
}
/* result[_first] now has first value fromLast=FALSE */
for(i=_first+1; i<nr+j*nr; i++) {
int_result[i] = int_x[i];
if(int_result[i] == NA_LOGICAL && gap < maxgap) {
int_result[i] = int_result[i-1];
gap++;
}
}
if((int)gap > (int)maxgap) { /* check that we don't have excessive trailing gap */
for(ii = i-1; ii > i-gap-1; ii--) {
int_result[ii] = NA_LOGICAL;
}
}
}
} else {
/* nr-2 is first position to fill fromLast=TRUE */
for(j=0; j < nc; j++) {
int_result[nr-1+j*nr] = int_x[nr-1+j*nr];
for(i=nr-2 + j*nr; i>=0+j*nr; i--) {
int_result[i] = int_x[i];
if(int_result[i] == NA_LOGICAL && gap < maxgap) {
int_result[i] = int_result[i+1];
gap++;
}
}
}
}
break;
case INTSXP:
int_x = INTEGER(x);
int_result = INTEGER(result);
if(!LOGICAL(fromLast)[0]) {
for(j=0; j < nc; j++) {
/* copy leading NAs */
_first = firstNonNACol(x, j);
//if(_first+1 == nr) continue;
for(i=0+j*nr; i < (_first+1); i++) {
int_result[i] = int_x[i];
}
/* result[_first] now has first value fromLast=FALSE */
for(i=_first+1; i<nr+j*nr; i++) {
int_result[i] = int_x[i];
if(int_result[i] == NA_INTEGER) {
if(limit > gap)
int_result[i] = int_result[i-1];
gap++;
} else {
if((int)gap > (int)maxgap) {
for(ii = i-1; ii > i-gap-1; ii--) {
int_result[ii] = NA_INTEGER;
}
}
gap=0;
}
}
if((int)gap > (int)maxgap) { /* check that we don't have excessive trailing gap */
for(ii = i-1; ii > i-gap-1; ii--) {
int_result[ii] = NA_INTEGER;
}
}
}
} else {
/* nr-2 is first position to fill fromLast=TRUE */
for(j=0; j < nc; j++) {
int_result[nr-1+j*nr] = int_x[nr-1+j*nr];
for(i=nr-2 + j*nr; i>=0+j*nr; i--) {
int_result[i] = int_x[i];
if(int_result[i] == NA_INTEGER) {
if(limit > gap)
int_result[i] = int_result[i+1];
gap++;
} else {
if((int)gap > (int)maxgap) {
for(ii = i+1; ii < i+gap+1; ii++) {
int_result[ii] = NA_INTEGER;
}
}
gap=0;
}
}
if((int)gap > (int)maxgap) { /* check that we don't have leading trailing gap */
for(ii = i+1; ii < i+gap+1; ii++) {
int_result[ii] = NA_INTEGER;
}
}
}
}
break;
case REALSXP:
real_x = REAL(x);
real_result = REAL(result);
if(!LOGICAL(fromLast)[0]) { /* fromLast=FALSE */
for(j=0; j < nc; j++) {
/* copy leading NAs */
_first = firstNonNACol(x, j);
//if(_first+1 == nr) continue;
for(i=0+j*nr; i < (_first+1); i++) {
real_result[i] = real_x[i];
}
/* result[_first] now has first value fromLast=FALSE */
for(i=_first+1; i<nr+j*nr; i++) {
real_result[i] = real_x[i];
if( ISNA(real_result[i]) || ISNAN(real_result[i])) {
if(limit > gap)
real_result[i] = real_result[i-1];
gap++;
} else {
if((int)gap > (int)maxgap) {
for(ii = i-1; ii > i-gap-1; ii--) {
real_result[ii] = NA_REAL;
}
}
gap=0;
}
}
if((int)gap > (int)maxgap) { /* check that we don't have excessive trailing gap */
for(ii = i-1; ii > i-gap-1; ii--) {
real_result[ii] = NA_REAL;
}
}
}
} else { /* fromLast=TRUE */
for(j=0; j < nc; j++) {
real_result[nr-1+j*nr] = real_x[nr-1+j*nr];
for(i=nr-2 + j*nr; i>=0+j*nr; i--) {
real_result[i] = real_x[i];
if(ISNA(real_result[i]) || ISNAN(real_result[i])) {
if(limit > gap)
real_result[i] = real_result[i+1];
gap++;
} else {
if((int)gap > (int)maxgap) {
for(ii = i+1; ii < i+gap+1; ii++) {
real_result[ii] = NA_REAL;
}
}
gap=0;
}
}
if((int)gap > (int)maxgap) { /* check that we don't have leading trailing gap */
for(ii = i+1; ii < i+gap+1; ii++) {
real_result[ii] = NA_REAL;
}
}
}
}
break;
default:
error("unsupported type");
break;
}
if(isXts(x)) {
setAttrib(result, R_DimSymbol, getAttrib(x, R_DimSymbol));
setAttrib(result, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol));
setAttrib(result, xts_IndexSymbol, getAttrib(x, xts_IndexSymbol));
copy_xtsCoreAttributes(x, result);
copy_xtsAttributes(x, result);
}
UNPROTECT(P);
return(result);
}
SEXP
KalmanFore(SEXP nahead, SEXP sZ, SEXP sa0, SEXP sP0, SEXP sT, SEXP sV,
SEXP sh, SEXP fast)
{
SEXP res, forecasts, se;
int n = asInteger(nahead);
int i, j, k, l;
double fc, tmp, *mm, *anew, *Pnew;
if (TYPEOF(sZ) != REALSXP ||
TYPEOF(sa0) != REALSXP || TYPEOF(sP0) != REALSXP ||
TYPEOF(sT) != REALSXP || TYPEOF(sV) != REALSXP)
error(_("invalid argument type"));
int p = LENGTH(sa0);
double *Z = REAL(sZ), *a = REAL(sa0), *P = REAL(sP0), *T = REAL(sT),
*V = REAL(sV), h = asReal(sh);
anew = (double *) R_alloc(p, sizeof(double));
Pnew = (double *) R_alloc(p * p, sizeof(double));
mm = (double *) R_alloc(p * p, sizeof(double));
PROTECT(res = allocVector(VECSXP, 2));
SET_VECTOR_ELT(res, 0, forecasts = allocVector(REALSXP, n));
SET_VECTOR_ELT(res, 1, se = allocVector(REALSXP, n));
if (!LOGICAL(fast)[0]){
PROTECT(sa0=duplicate(sa0));
a=REAL(sa0);
PROTECT(sP0=duplicate(sP0));
P=REAL(sP0);
}
for (l = 0; l < n; l++) {
fc = 0.0;
for (i = 0; i < p; i++) {
tmp = 0.0;
for (k = 0; k < p; k++)
tmp += T[i + p * k] * a[k];
anew[i] = tmp;
fc += tmp * Z[i];
}
for (i = 0; i < p; i++)
a[i] = anew[i];
REAL(forecasts)[l] = fc;
for (i = 0; i < p; i++)
for (j = 0; j < p; j++) {
tmp = 0.0;
for (k = 0; k < p; k++)
tmp += T[i + p * k] * P[k + p * j];
mm[i + p * j] = tmp;
}
for (i = 0; i < p; i++)
for (j = 0; j < p; j++) {
tmp = V[i + p * j];
for (k = 0; k < p; k++)
tmp += mm[i + p * k] * T[j + p * k];
Pnew[i + p * j] = tmp;
}
tmp = h;
for (i = 0; i < p; i++)
for (j = 0; j < p; j++) {
P[i + j * p] = Pnew[i + j * p];
tmp += Z[i] * Z[j] * P[i + j * p];
}
REAL(se)[l] = tmp;
}
UNPROTECT(1);
return res;
}
SEXP mc_select_children(SEXP sTimeout, SEXP sWhich)
{
int maxfd = 0, sr, zombies = 0;
unsigned int wlen = 0, wcount = 0;
SEXP res;
int *res_i, *which = 0;
child_info_t *ci = children;
fd_set fs;
struct timeval tv = { 0, 0 }, *tvp = &tv;
if (isReal(sTimeout) && LENGTH(sTimeout) == 1) {
double tov = asReal(sTimeout);
if (tov < 0.0) tvp = 0; /* Note: I'm not sure we really should allow this .. */
else {
tv.tv_sec = (int) tov;
tv.tv_usec = (int) ((tov - ((double) tv.tv_sec)) * 1000000.0);
}
}
if (TYPEOF(sWhich) == INTSXP && LENGTH(sWhich)) {
which = INTEGER(sWhich);
wlen = LENGTH(sWhich);
}
clean_zombies();
FD_ZERO(&fs);
while (ci && ci->pid) {
if (ci->pfd == -1) zombies++;
if (ci->pfd > maxfd) maxfd = ci->pfd;
if (ci->pfd > 0) {
if (which) { /* check for the FD only if it's on the list */
unsigned int k = 0;
while (k < wlen)
if (which[k++] == ci->pid) {
FD_SET(ci->pfd, &fs);
wcount++;
break;
}
} else FD_SET(ci->pfd, &fs);
}
ci = ci -> next;
}
/* if there are any closed children, remove them - don't bother otherwise */
if (zombies) rm_closed();
#ifdef MC_DEBUG
Dprintf("select_children: maxfd=%d, wlen=%d, wcount=%d, zombies=%d, timeout=%d:%d\n", maxfd, wlen, wcount, zombies, (int)tv.tv_sec, (int)tv.tv_usec);
#endif
if (maxfd == 0 || (wlen && !wcount))
return R_NilValue; /* NULL signifies no children to tend to */
sr = select(maxfd + 1, &fs, 0, 0, tvp);
#ifdef MC_DEBUG
Dprintf(" sr = %d\n", sr);
#endif
if (sr < 0) {
/* we can land here when a child terminated due to arriving SIGCHLD.
For simplicity we treat this as timeout. The alernative would be to
go back to select, but potentially this could lead to a much longer
total timeout */
if (errno == EINTR)
return ScalarLogical(TRUE);
warning(_("error '%s' in select"), strerror(errno));
return ScalarLogical(FALSE); /* FALSE on select error */
}
if (sr < 1) return ScalarLogical(1); /* TRUE on timeout */
ci = children;
maxfd = 0;
while (ci && ci->pid) { /* pass 1 - count the FDs (in theory not
necessary since that's what select
should have returned) */
if (ci->pfd > 0 && FD_ISSET(ci->pfd, &fs)) maxfd++;
ci = ci -> next;
}
ci = children;
#ifdef MC_DEBUG
Dprintf(" - read select %d children: ", maxfd);
#endif
res = allocVector(INTSXP, maxfd);
res_i = INTEGER(res);
while (ci && ci->pid) { /* pass 2 - fill the array */
if (ci->pfd > 0 && FD_ISSET(ci->pfd, &fs)) (res_i++)[0] = ci->pid;
#ifdef MC_DEBUG
if (ci->pfd > 0 && FD_ISSET(ci->pfd, &fs)) Dprintf("%d ", ci->pid);
#endif
ci = ci -> next;
}
#ifdef MC_DEBUG
Dprintf("\n");
#endif
return res;
}
SEXP do_rgb(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP c, r, g, b, a, nam;
int OP, i, l_max, nr, ng, nb, na;
Rboolean max_1 = FALSE;
double mV = 0.0; /* -Wall */
checkArity(op, args);
OP = PRIMVAL(op);
if(OP) {/* op == 1: rgb256() :*/
PROTECT(r = coerceVector(CAR(args), INTSXP)); args = CDR(args);
PROTECT(g = coerceVector(CAR(args), INTSXP)); args = CDR(args);
PROTECT(b = coerceVector(CAR(args), INTSXP)); args = CDR(args);
PROTECT(a = coerceVector(CAR(args), INTSXP)); args = CDR(args);
}
else {
PROTECT(r = coerceVector(CAR(args), REALSXP)); args = CDR(args);
PROTECT(g = coerceVector(CAR(args), REALSXP)); args = CDR(args);
PROTECT(b = coerceVector(CAR(args), REALSXP)); args = CDR(args);
PROTECT(a = coerceVector(CAR(args), REALSXP)); args = CDR(args);
mV = asReal(CAR(args)); args = CDR(args);
max_1 = (mV == 1.);
}
nr = LENGTH(r); ng = LENGTH(g); nb = LENGTH(b); na = LENGTH(a);
if (nr <= 0 || ng <= 0 || nb <= 0 || na <= 0) {
UNPROTECT(4);
return(allocVector(STRSXP, 0));
}
l_max = nr;
if (l_max < ng) l_max = ng;
if (l_max < nb) l_max = nb;
if (l_max < na) l_max = na;
PROTECT(nam = coerceVector(CAR(args), STRSXP)); args = CDR(args);
if (length(nam) != 0 && length(nam) != l_max)
errorcall(call, _("invalid names vector"));
PROTECT(c = allocVector(STRSXP, l_max));
#define _R_set_c_RGBA(_R,_G,_B,_A) \
for (i = 0; i < l_max; i++) \
SET_STRING_ELT(c, i, mkChar(RGBA2rgb(_R,_G,_B,_A)))
if(OP) { /* OP == 1: rgb256() :*/
_R_set_c_RGBA(CheckColor(INTEGER(r)[i%nr]),
CheckColor(INTEGER(g)[i%ng]),
CheckColor(INTEGER(b)[i%nb]),
CheckAlpha(INTEGER(a)[i%na]));
}
else if(max_1) {
_R_set_c_RGBA(ScaleColor(REAL(r)[i%nr]),
ScaleColor(REAL(g)[i%ng]),
ScaleColor(REAL(b)[i%nb]),
ScaleAlpha(REAL(a)[i%na]));
}
else { /* maxColorVal not in {1, 255} */
_R_set_c_RGBA(ScaleColor(REAL(r)[i%nr] / mV),
ScaleColor(REAL(g)[i%ng] / mV),
ScaleColor(REAL(b)[i%nb] / mV),
ScaleAlpha(REAL(a)[i%na] / mV));
}
if (length(nam) != 0)
setAttrib(c, R_NamesSymbol, nam);
UNPROTECT(6);
return c;
}
SEXP colCounts(SEXP x, SEXP dim, SEXP rows, SEXP cols, SEXP value, SEXP what, SEXP naRm, SEXP hasNA) {
SEXP ans;
int narm, hasna, what2;
R_xlen_t nrow, ncol;
/* Argument 'x' and 'dim': */
assertArgMatrix(x, dim, (R_TYPE_LGL | R_TYPE_INT | R_TYPE_REAL), "x");
nrow = asR_xlen_t(dim, 0);
ncol = asR_xlen_t(dim, 1);
/* Argument 'value': */
if (length(value) != 1)
error("Argument 'value' must be a single value.");
if (!isNumeric(value))
error("Argument 'value' must be a numeric value.");
/* Argument 'what': */
what2 = asInteger(what);
if (what2 < 0 || what2 > 2)
error("INTERNAL ERROR: Unknown value of 'what' for rowCounts: %d", what2);
/* Argument 'naRm': */
narm = asLogicalNoNA(naRm, "na.rm");
/* Argument 'hasNA': */
hasna = asLogicalNoNA(hasNA, "hasNA");
/* Argument 'rows' and 'cols': */
R_xlen_t nrows, ncols;
int rowsType, colsType;
void *crows = validateIndices(rows, nrow, 0, &nrows, &rowsType);
void *ccols = validateIndices(cols, ncol, 0, &ncols, &colsType);
/* R allocate an integer vector of length 'ncol' */
PROTECT(ans = allocVector(INTSXP, ncols));
if (isReal(x)) {
colCounts_Real[rowsType][colsType](REAL(x), nrow, ncol, crows, nrows, ccols, ncols, asReal(value), what2, narm, hasna, INTEGER(ans));
} else if (isInteger(x)) {
colCounts_Integer[rowsType][colsType](INTEGER(x), nrow, ncol, crows, nrows, ccols, ncols, asInteger(value), what2, narm, hasna, INTEGER(ans));
} else if (isLogical(x)) {
colCounts_Logical[rowsType][colsType](LOGICAL(x), nrow, ncol, crows, nrows, ccols, ncols, asLogical(value), what2, narm, hasna, INTEGER(ans));
}
UNPROTECT(1);
return(ans);
} // colCounts()
int KviKvsVariant::compare(const KviKvsVariant * pOther, bool bPreferNumeric) const
{
if(!pOther)
return isEqualToNothing() ? CMP_EQUAL : CMP_THISGREATER;
if(!pOther->m_pData)
return isEqualToNothing() ? CMP_EQUAL : CMP_THISGREATER;
if(!m_pData)
return pOther->isEqualToNothing() ? CMP_EQUAL : CMP_OTHERGREATER;
switch(m_pData->m_eType)
{
case KviKvsVariantData::HObject:
switch(pOther->m_pData->m_eType)
{
case KviKvsVariantData::HObject:
if(m_pData->m_u.hObject == pOther->m_pData->m_u.hObject)
return CMP_EQUAL;
if(m_pData->m_u.hObject == ((kvs_hobject_t)0))
return CMP_OTHERGREATER;
return CMP_THISGREATER;
break;
case KviKvsVariantData::Integer:
return -1 * KviKvsVariantComparison::compareIntHObject(pOther,this);
break;
case KviKvsVariantData::Real:
return -1 * KviKvsVariantComparison::compareRealHObject(pOther,this);
break;
case KviKvsVariantData::String:
return -1 * KviKvsVariantComparison::compareStringHObject(pOther,this);
break;
case KviKvsVariantData::Boolean:
return -1 * KviKvsVariantComparison::compareBoolHObject(pOther,this);
break;
case KviKvsVariantData::Hash:
return KviKvsVariantComparison::compareHObjectHash(this,pOther);
break;
case KviKvsVariantData::Array:
return KviKvsVariantComparison::compareHObjectArray(this,pOther);
break;
default: // just make gcc happy
break;
}
break;
case KviKvsVariantData::Integer:
switch(pOther->m_pData->m_eType)
{
case KviKvsVariantData::HObject:
return KviKvsVariantComparison::compareIntHObject(this,pOther);
break;
case KviKvsVariantData::Integer:
if(m_pData->m_u.iInt == pOther->m_pData->m_u.iInt)
return CMP_EQUAL;
if(m_pData->m_u.iInt > pOther->m_pData->m_u.iInt)
return CMP_THISGREATER;
return CMP_OTHERGREATER;
break;
case KviKvsVariantData::Real:
return KviKvsVariantComparison::compareIntReal(this,pOther);
break;
case KviKvsVariantData::String:
return KviKvsVariantComparison::compareIntString(this,pOther);
break;
case KviKvsVariantData::Boolean:
return KviKvsVariantComparison::compareIntBool(this,pOther);
break;
case KviKvsVariantData::Hash:
return KviKvsVariantComparison::compareIntHash(this,pOther);
break;
case KviKvsVariantData::Array:
return KviKvsVariantComparison::compareIntArray(this,pOther);
break;
default: // just make gcc happy
break;
}
break;
case KviKvsVariantData::Real:
switch(pOther->m_pData->m_eType)
{
case KviKvsVariantData::HObject:
return KviKvsVariantComparison::compareRealHObject(this,pOther);
break;
case KviKvsVariantData::Integer:
return -1 * KviKvsVariantComparison::compareIntReal(pOther,this);
break;
case KviKvsVariantData::Real:
if(*(m_pData->m_u.pReal) == *(pOther->m_pData->m_u.pReal))
return CMP_EQUAL;
if(*(m_pData->m_u.pReal) > *(pOther->m_pData->m_u.pReal))
return CMP_THISGREATER;
return CMP_OTHERGREATER;
break;
case KviKvsVariantData::String:
return KviKvsVariantComparison::compareRealString(this,pOther);
break;
case KviKvsVariantData::Boolean:
return KviKvsVariantComparison::compareRealBool(this,pOther);
break;
case KviKvsVariantData::Hash:
return KviKvsVariantComparison::compareRealHash(this,pOther);
break;
case KviKvsVariantData::Array:
return KviKvsVariantComparison::compareRealArray(this,pOther);
break;
default: // just make gcc happy
break;
}
break;
case KviKvsVariantData::String:
switch(pOther->m_pData->m_eType)
{
case KviKvsVariantData::String:
if(bPreferNumeric)
{
// prefer numeric comparison
double dReal1;
double dReal2;
if(asReal(dReal1))
{
if(pOther->asReal(dReal2))
{
if(dReal1 == dReal2)
return CMP_EQUAL;
if(dReal1 > dReal2)
return CMP_THISGREATER;
return CMP_OTHERGREATER;
}
}
}
return -1 * m_pData->m_u.pString->compare(*(pOther->m_pData->m_u.pString),Qt::CaseInsensitive);
case KviKvsVariantData::Real:
return -1 * KviKvsVariantComparison::compareRealString(pOther,this);
case KviKvsVariantData::Integer:
return -1 * KviKvsVariantComparison::compareIntString(pOther,this);
case KviKvsVariantData::Boolean:
return -1 * KviKvsVariantComparison::compareBoolString(pOther,this);
break;
case KviKvsVariantData::Hash:
return KviKvsVariantComparison::compareStringHash(this,pOther);
break;
case KviKvsVariantData::Array:
return KviKvsVariantComparison::compareStringArray(this,pOther);
break;
case KviKvsVariantData::HObject:
return KviKvsVariantComparison::compareStringHObject(this,pOther);
break;
default:
break;
}
break;
case KviKvsVariantData::Hash:
switch(pOther->m_pData->m_eType)
{
case KviKvsVariantData::String:
return -1 * KviKvsVariantComparison::compareStringHash(pOther,this);
case KviKvsVariantData::Real:
return -1 * KviKvsVariantComparison::compareRealHash(pOther,this);
break;
case KviKvsVariantData::Integer:
return -1 * KviKvsVariantComparison::compareIntHash(pOther,this);
break;
case KviKvsVariantData::Boolean:
return -1 * KviKvsVariantComparison::compareBoolHash(pOther,this);
break;
case KviKvsVariantData::Hash:
if(m_pData->m_u.pHash->size() > pOther->m_pData->m_u.pHash->size())
return CMP_THISGREATER;
if(m_pData->m_u.pHash->size() == pOther->m_pData->m_u.pHash->size())
return CMP_EQUAL;
return CMP_OTHERGREATER;
break;
case KviKvsVariantData::Array:
return -1 * KviKvsVariantComparison::compareArrayHash(pOther,this);
break;
case KviKvsVariantData::HObject:
return -1 * KviKvsVariantComparison::compareHObjectHash(pOther,this);
break;
default:
break;
}
break;
case KviKvsVariantData::Array:
switch(pOther->m_pData->m_eType)
{
case KviKvsVariantData::String:
return -1 * KviKvsVariantComparison::compareStringArray(pOther,this);
case KviKvsVariantData::Real:
return -1 * KviKvsVariantComparison::compareRealArray(pOther,this);
case KviKvsVariantData::Integer:
return -1 * KviKvsVariantComparison::compareIntArray(pOther,this);
case KviKvsVariantData::Boolean:
return -1 * KviKvsVariantComparison::compareBoolArray(pOther,this);
break;
case KviKvsVariantData::Hash:
return KviKvsVariantComparison::compareArrayHash(this,pOther);
break;
case KviKvsVariantData::Array:
if(m_pData->m_u.pArray->size() > pOther->m_pData->m_u.pArray->size())
return CMP_THISGREATER;
if(m_pData->m_u.pArray->size() == pOther->m_pData->m_u.pArray->size())
return CMP_EQUAL;
return CMP_OTHERGREATER;
break;
case KviKvsVariantData::HObject:
return -1 * KviKvsVariantComparison::compareHObjectArray(pOther,this);
break;
default:
break;
}
break;
case KviKvsVariantData::Boolean:
switch(pOther->m_pData->m_eType)
{
case KviKvsVariantData::String:
return KviKvsVariantComparison::compareBoolString(this,pOther);
break;
case KviKvsVariantData::Real:
return -1 * KviKvsVariantComparison::compareRealBool(pOther,this);
break;
case KviKvsVariantData::Integer:
return -1 * KviKvsVariantComparison::compareIntBool(pOther,this);
break;
case KviKvsVariantData::Boolean:
if(m_pData->m_u.bBoolean == pOther->m_pData->m_u.bBoolean)
return CMP_EQUAL;
if(m_pData->m_u.bBoolean)
return CMP_THISGREATER;
return CMP_OTHERGREATER;
break;
case KviKvsVariantData::Hash:
return KviKvsVariantComparison::compareBoolHash(this,pOther);
break;
case KviKvsVariantData::Array:
return KviKvsVariantComparison::compareBoolArray(this,pOther);
break;
case KviKvsVariantData::HObject:
return KviKvsVariantComparison::compareBoolHObject(this,pOther);
break;
default:
break;
}
break;
default: // should never happen anyway
break;
}
return CMP_THISGREATER; // should never happen
}
SEXP iterative_correction(SEXP avecount, SEXP anchor, SEXP target, SEXP local,
SEXP nfrags, SEXP iter, SEXP exlocal, SEXP lowdiscard, SEXP winsorhigh) try {
// Checking vector type and length.
if (!isNumeric(avecount)) { throw std::runtime_error("average counts must be supplied as a double-precision vector"); }
if (!isInteger(anchor) || !isInteger(target)) { throw std::runtime_error("anchor/target indices must be supplied as an integer vector"); }
if (!isLogical(local)) { throw std::runtime_error("local specifier should be a logical vector"); }
const int npairs=LENGTH(avecount);
if (npairs!=LENGTH(anchor) || npairs!=LENGTH(target) || npairs!=LENGTH(local)) { throw std::runtime_error("lengths of vectors are not equal"); }
const double* acptr=REAL(avecount);
const int* aptr=INTEGER(anchor),
* tptr=INTEGER(target),
* lptr=LOGICAL(local);
// Checking scalar type.
if (!isInteger(nfrags) || LENGTH(nfrags)!=1) { throw std::runtime_error("number of fragments should be an integer scalar"); }
if (!isInteger(iter) || LENGTH(iter)!=1) { throw std::runtime_error("number of iterations should be an integer scalar"); }
if (!isInteger(exlocal) || LENGTH(exlocal)!=1) { throw std::runtime_error("exclusion specifier should be an integer scalar"); }
const int numfrags=asInteger(nfrags),
iterations=asInteger(iter),
excluded=asInteger(exlocal);
if (!isNumeric(lowdiscard) || LENGTH(lowdiscard)!=1) { throw std::runtime_error("proportion to discard should be a double-precision scalar"); }
const double discarded=asReal(lowdiscard);
if (!isNumeric(winsorhigh) || LENGTH(winsorhigh)!=1) { throw std::runtime_error("proportion to winsorize should be a double-precision scalar"); }
const double winsorized=asReal(winsorhigh);
SEXP output=PROTECT(allocVector(VECSXP, 3));
try {
// Setting up a SEXP to hold the working probabilities (ultimately the truth).
SET_VECTOR_ELT(output, 0, allocVector(REALSXP, npairs));
double* wptr=REAL(VECTOR_ELT(output, 0));
std::copy(acptr, acptr+npairs, wptr);
// Excluding highly local interactions.
int num_values=npairs;
bool drop_intras=(excluded==NA_INTEGER);
if (drop_intras || excluded >= 0) {
for (int j=0; j<npairs; ++j) {
if (lptr[j] && (drop_intras || aptr[j]-tptr[j] <= excluded)) {
wptr[j]=R_NaReal;
--num_values;
}
}
}
/**************************************************
* Getting rid of unstable or extreme elements.
**************************************************/
// Winsorizing for the most abundant interactions.
const int todrop=int(double(num_values)*winsorized);
if (todrop>0) {
int* ordered=new int[npairs];
try {
for (int i=0; i<npairs; ++i) { ordered[i]=i; }
orderer current(acptr);
std::sort(ordered, ordered+npairs, current);
// Identifying the winsorizing value.
int curcount=0;
double winsor_val=R_NaReal;
for (int i=npairs-1; i>=0; --i) {
const int& curo=ordered[i];
if (ISNA(wptr[curo])) { continue; }
++curcount;
if (curcount > todrop) {
winsor_val=wptr[curo];
break;
}
}
// Applying said value to all high-abundance interactions.
if (ISNA(winsor_val)) { throw std::runtime_error("specified winsorizing proportion censors all data"); }
curcount=0;
for (int i=npairs-1; i>=0; --i) {
const int& curo=ordered[i];
if (ISNA(wptr[curo])) { continue; }
wptr[curo]=winsor_val;
++curcount;
if (curcount > todrop) { break; }
}
} catch (std::exception& e){
delete [] ordered;
throw;
}
delete[] ordered;
}
// Bias and coverage vectors.
SET_VECTOR_ELT(output, 1, allocVector(REALSXP, numfrags));
double* bias=REAL(VECTOR_ELT(output, 1)),
* biaptr=bias-1;
for (int i=0; i<numfrags; ++i) { bias[i]=R_NaReal; }
for (int pr=0; pr<npairs; ++pr) {
if (!ISNA(wptr[pr])) { biaptr[aptr[pr]]=biaptr[tptr[pr]]=1; }
}
double* coverage=(double*)R_alloc(numfrags, sizeof(double));
for (int i=0; i<numfrags; ++i) { coverage[i]=0; }
double* covptr=coverage-1; // To deal with 1-based indices.
// Removing low-abundance fragments.
if (discarded > 0) {
for (int pr=0; pr<npairs; ++pr) { // Computing the coverage.
if (ISNA(wptr[pr])) { continue; }
covptr[aptr[pr]]+=wptr[pr];
covptr[tptr[pr]]+=wptr[pr];
}
int* ordering=new int [numfrags];
try {
for (int i=0; i<numfrags; ++i) { ordering[i]=i; }
orderer current(coverage);
std::sort(ordering, ordering+numfrags, current);
// Ignoring empty rows.
int counter=0;
while (counter < numfrags && ISNA(bias[ordering[counter]])){ ++counter; }
// Filtering out low-abundance rows.
const int leftover=int(discarded*double(numfrags-counter))+counter;
while (counter < leftover) {
bias[ordering[counter]]=R_NaReal;
++counter;
}
// Setting everything else back to zero.
while (counter < numfrags) {
coverage[ordering[counter]]=0;
++counter;
}
} catch (std::exception& e) {
delete [] ordering;
throw;
}
delete [] ordering;
// Propogating the filters through the interactions to remove anything with an anchor in the removed fragments.
for (int pr=0; pr<npairs; ++pr) {
if (ISNA(wptr[pr])) { continue; }
if (ISNA(biaptr[aptr[pr]]) || ISNA(biaptr[tptr[pr]])) { wptr[pr]=R_NaReal; }
}
for (int i=0; i<numfrags; ++i) { bias[i]=R_NaReal; }
for (int pr=0; pr<npairs; ++pr) {
if (!ISNA(wptr[pr])) { biaptr[aptr[pr]]=biaptr[tptr[pr]]=1; }
}
}
// Something to hold a diagnostic (i.e., the maximum step).
SET_VECTOR_ELT(output, 2, allocVector(REALSXP, iterations));
double* optr=REAL(VECTOR_ELT(output, 2));
/********************************************************
* Now, actually performing the iterative correction. ***
********************************************************/
for (int it=0; it<iterations; ++it) {
for (int pr=0; pr<npairs; ++pr) { // Computing the coverage (ignoring locals, if necessary).
if (ISNA(wptr[pr])) { continue; }
covptr[aptr[pr]]+=wptr[pr];
covptr[tptr[pr]]+=wptr[pr];
}
/* Computing the 'aditional bias' vector, to take the mean across all fragments.
* The exact value of the mean doesn't really matter, it just serves to slow down
* the algorithm to avoid overshooting the mark and lack of convergence. Everything
* ends up being the same so long as the column sums approach 1.
*/
// double mean_of_all=0;
// for (int i=0; i<numfrags; ++i) { if (!ISNA(coverage[i])) { mean_of_all+=coverage[i]; } }
// mean_of_all/=numfrags;
// for (int i=0; i<numfrags; ++i) { if (!ISNA(coverage[i])) { coverage[i]/=mean_of_all; } }
/* Okay, that didn't really work. The strategy that is described in the paper fails to
* give me contact probabilities that sum to 1. So instead, I'm using the coverage
* itself to divide the working probabilities. Square rooting is necessary to avoid
* instability during iteration.
*/
for (int i=0; i<numfrags; ++i) { if (!ISNA(bias[i])) { coverage[i]=std::sqrt(coverage[i]); } }
// Dividing the working matrix with the (geometric mean of the) additional biases.
for (int pr=0; pr<npairs; ++pr){
if (!ISNA(wptr[pr])) { wptr[pr]/=covptr[aptr[pr]]*covptr[tptr[pr]]; }
}
// Multiplying the biases by additional biases, and cleaning out coverage. We store
// the maximum step to see how far off convergence it is.
double& maxed=(optr[it]=0);
for (int i=0; i<numfrags; ++i) {
if (!ISNA(bias[i])) {
double& cur_cov=coverage[i];
if (cur_cov > maxed) { maxed=cur_cov; }
else if (1/cur_cov > maxed) { maxed=1/cur_cov; }
bias[i]*=cur_cov;
cur_cov=0;
}
}
}
/* Recalculating the contact probabilities, using the estimated biases,
* to get normalized values for Winsorized or discarded bin pairs.
* Discarded bins can't be salvaged, though.
*/
for (int pr=0; pr<npairs; ++pr) {
if (ISNA(biaptr[aptr[pr]]) || ISNA(biaptr[tptr[pr]])) { continue; }
wptr[pr] = acptr[pr]/biaptr[aptr[pr]]/biaptr[tptr[pr]];
}
} catch (std::exception& e) {
UNPROTECT(1);
throw;
}
UNPROTECT(1);
return output;
} catch (std::exception& e) {
return mkString(e.what());
}
SEXP mc_select_children(SEXP sTimeout, SEXP sWhich)
{
int maxfd = 0, sr, zombies = 0;
unsigned int wlen = 0, wcount = 0;
SEXP res;
int *res_i, *which = 0;
child_info_t *ci = children;
fd_set fs;
struct timeval tv = { 0, 0 }, *tvp = &tv;
if (isReal(sTimeout) && LENGTH(sTimeout) == 1) {
double tov = asReal(sTimeout);
if (tov < 0.0) tvp = 0; /* Note: I'm not sure we really should allow this .. */
else {
tv.tv_sec = (int) tov;
tv.tv_usec = (int) ((tov - ((double) tv.tv_sec)) * 1000000.0);
}
}
if (TYPEOF(sWhich) == INTSXP && LENGTH(sWhich)) {
which = INTEGER(sWhich);
wlen = LENGTH(sWhich);
}
{
int wstat;
while (waitpid(-1, &wstat, WNOHANG) > 0) ; /* check for zombies */
}
FD_ZERO(&fs);
while (ci && ci->pid) {
if (ci->pfd == -1) zombies++;
if (ci->pfd > maxfd) maxfd = ci->pfd;
if (ci->pfd > 0) {
if (which) { /* check for the FD only if it's on the list */
unsigned int k = 0;
while (k < wlen)
if (which[k++] == ci->pid) {
FD_SET(ci->pfd, &fs);
wcount++;
break;
}
} else FD_SET(ci->pfd, &fs);
}
ci = ci -> next;
}
#ifdef MC_DEBUG
Dprintf("select_children: maxfd=%d, wlen=%d, wcount=%d, zombies=%d, timeout=%d:%d\n", maxfd, wlen, wcount, zombies, (int)tv.tv_sec, (int)tv.tv_usec);
#endif
if (zombies) { /* oops, this should never really happen - it did
* while we had a bug in rm_child_ but hopefully
* not anymore */
while (zombies) { /* this is rather more complicated than it
* should be if we used pointers to delete,
* but well ... */
ci = children;
while (ci) {
if (ci->pfd == -1) {
#ifdef MC_DEBUG
Dprintf("detected zombie: pid=%d, pfd=%d, sifd=%d\n",
ci->pid, ci->pfd, ci->sifd);
#endif
rm_child_(ci->pid);
zombies--;
break;
}
ci = ci->next;
}
if (!ci) break;
}
}
if (maxfd == 0 || (wlen && !wcount))
return R_NilValue; /* NULL signifies no children to tend to */
sr = select(maxfd + 1, &fs, 0, 0, tvp);
#ifdef MC_DEBUG
Dprintf(" sr = %d\n", sr);
#endif
if (sr < 0) {
warning(_("error '%s' in select"), strerror(errno));
return ScalarLogical(0); /* FALSE on select error */
}
if (sr < 1) return ScalarLogical(1); /* TRUE on timeout */
ci = children;
maxfd = 0;
while (ci && ci->pid) { /* pass 1 - count the FDs (in theory not
necessary since that's what select
should have returned) */
if (ci->pfd > 0 && FD_ISSET(ci->pfd, &fs)) maxfd++;
ci = ci -> next;
}
ci = children;
#ifdef MC_DEBUG
Dprintf(" - read select %d children: ", maxfd);
#endif
res = allocVector(INTSXP, maxfd);
res_i = INTEGER(res);
while (ci && ci->pid) { /* pass 2 - fill the array */
if (ci->pfd > 0 && FD_ISSET(ci->pfd, &fs)) (res_i++)[0] = ci->pid;
#ifdef MC_DEBUG
if (ci->pfd > 0 && FD_ISSET(ci->pfd, &fs)) Dprintf("%d ", ci->pid);
#endif
ci = ci -> next;
}
#ifdef MC_DEBUG
Dprintf("\n");
#endif
return res;
}
SEXP R_handle_setopt(SEXP ptr, SEXP keys, SEXP values){
CURL *handle = get_handle(ptr);
SEXP optnames = getAttrib(values, R_NamesSymbol);
if(!isInteger(keys))
error("keys` must be an integer");
if(!isVector(values))
error("`values` must be a list");
for(int i = 0; i < length(keys); i++){
int key = INTEGER(keys)[i];
const char* optname = CHAR(STRING_ELT(optnames, i));
SEXP val = VECTOR_ELT(values, i);
if(val == R_NilValue){
assert(curl_easy_setopt(handle, key, NULL));
} else if (key == CURLOPT_PROGRESSFUNCTION) {
if (TYPEOF(val) != CLOSXP)
error("Value for option %s (%d) must be a function.", optname, key);
assert(curl_easy_setopt(handle, CURLOPT_PROGRESSFUNCTION,
(curl_progress_callback) R_curl_callback_progress));
assert(curl_easy_setopt(handle, CURLOPT_PROGRESSDATA, val));
} else if (key == CURLOPT_READFUNCTION) {
if (TYPEOF(val) != CLOSXP)
error("Value for option %s (%d) must be a function.", optname, key);
assert(curl_easy_setopt(handle, CURLOPT_READFUNCTION,
(curl_read_callback) R_curl_callback_read));
assert(curl_easy_setopt(handle, CURLOPT_READDATA, val));
} else if (key == CURLOPT_DEBUGFUNCTION) {
if (TYPEOF(val) != CLOSXP)
error("Value for option %s (%d) must be a function.", optname, key);
assert(curl_easy_setopt(handle, CURLOPT_DEBUGFUNCTION,
(curl_debug_callback) R_curl_callback_debug));
assert(curl_easy_setopt(handle, CURLOPT_DEBUGDATA, val));
} else if (opt_is_linked_list(key)) {
error("Option %s (%d) not supported.", optname, key);
} else if(key < 10000){
if(!isNumeric(val) || length(val) != 1) {
error("Value for option %s (%d) must be a number.", optname, key);
}
assert(curl_easy_setopt(handle, key, (long) asInteger(val)));
} else if(key < 20000){
switch (TYPEOF(val)) {
case RAWSXP:
assert(curl_easy_setopt(handle, key, RAW(val)));
break;
case STRSXP:
if (length(val) != 1)
error("Value for option %s (%d) must be length-1 string", optname, key);
assert(curl_easy_setopt(handle, key, CHAR(STRING_ELT(val, 0))));
break;
default:
error("Value for option %s (%d) must be a string or raw vector.", optname, key);
}
} else if(key >= 30000 && key < 40000){
if(!isNumeric(val) || length(val) != 1) {
error("Value for option %s (%d) must be a number.", optname, key);
}
assert(curl_easy_setopt(handle, key, (curl_off_t) asReal(val)));
} else {
error("Option %s (%d) not supported.", optname, key);
}
}
return ScalarLogical(1);
}
SEXP objFun_optimalf ( SEXP f, SEXP lsp, SEXP margin, SEXP equity,
SEXP constrFun, SEXP constrVal, SEXP env )
{
int P=0;
double *d_fval = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 2)))); P++;
double *d_maxloss = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 3)))); P++;
double *d_f = REAL(PROTECT(AS_NUMERIC(f))); P++;
double *d_margin, d_equity, maxU; /* -Wall */
int len = length(f);
/* is changing 'lsp' stupid / dangerous? */
for(int i=0; i < len; i++) {
d_fval[i] = d_f[i];
}
SEXP s_ghpr, s_cval, fcall;
/* Calculate GHPR */
PROTECT(s_ghpr = ghpr(lsp)); P++;
double d_ghpr = -asReal(s_ghpr);
if(d_ghpr < -1) {
/* Margin constraint */
if( !isNull(margin) && !isNull(equity) ) {
d_margin = REAL(PROTECT(AS_NUMERIC(margin))); P++;
d_equity = asReal(equity);
maxU = 0;
for(int i=0; i < len; i++) {
maxU += d_f[i] * d_margin[i] / -d_maxloss[i];
}
maxU *= d_equity;
if(maxU > d_equity) {
d_ghpr = R_PosInf;
}
} /* Margin constraint */
/* Constraint function */
if( !isNull(constrFun) ) {
if( !isFunction(constrFun) )
error("constrFun is not a function");
PROTECT(fcall = lang3(constrFun, lsp, R_DotsSymbol)); P++;
PROTECT(s_cval = eval(fcall, env)); P++;
if( asReal(s_cval) >= asReal(constrVal) ) {
d_ghpr = R_PosInf;
}
}
} else {
d_ghpr = R_PosInf;
}
UNPROTECT(P);
return(ScalarReal(d_ghpr));
}
/*
cairo(filename, type, width, height, pointsize, bg, res, antialias,
quality, family)
*/
SEXP in_Cairo(SEXP args)
{
pGEDevDesc gdd;
SEXP sc;
const char *filename, *family;
int type, quality, width, height, pointsize, bgcolor, res, antialias;
double dpi;
const void *vmax = vmaxget();
args = CDR(args); /* skip entry point name */
if (!isString(CAR(args)) || LENGTH(CAR(args)) < 1)
error(_("invalid '%s' argument"), "filename");
filename = translateChar(STRING_ELT(CAR(args), 0));
args = CDR(args);
type = asInteger(CAR(args));
if(type == NA_INTEGER || type <= 0)
error(_("invalid '%s' argument"), "type");
args = CDR(args);
width = asInteger(CAR(args));
if(width == NA_INTEGER || width <= 0)
error(_("invalid '%s' argument"), "width");
args = CDR(args);
height = asInteger(CAR(args));
if(height == NA_INTEGER || height <= 0)
error(_("invalid '%s' argument"), "height");
args = CDR(args);
pointsize = asInteger(CAR(args));
if(pointsize == NA_INTEGER || pointsize <= 0)
error(_("invalid '%s' argument"), "pointsize");
args = CDR(args);
sc = CAR(args);
if (!isString(sc) && !isInteger(sc) && !isLogical(sc) && !isReal(sc))
error(_("invalid '%s' value"), "bg");
bgcolor = RGBpar(sc, 0);
args = CDR(args);
res = asInteger(CAR(args));
args = CDR(args);
antialias = asInteger(CAR(args));
if(antialias == NA_INTEGER)
error(_("invalid '%s' argument"), "antialias");
args = CDR(args);
quality = asInteger(CAR(args));
if(quality == NA_INTEGER || quality < 0 || quality > 100)
error(_("invalid '%s' argument"), "quality");
args = CDR(args);
if (!isString(CAR(args)) || LENGTH(CAR(args)) < 1)
error(_("invalid '%s' argument"), "family");
family = translateChar(STRING_ELT(CAR(args), 0));
args = CDR(args);
dpi = asReal(CAR(args));
if(ISNAN(dpi) || dpi <= 0)
error(_("invalid '%s' argument"), "dpi");
R_GE_checkVersionOrDie(R_GE_version);
R_CheckDeviceAvailable();
BEGIN_SUSPEND_INTERRUPTS {
pDevDesc dev;
/* Allocate and initialize the device driver data */
if (!(dev = (pDevDesc) calloc(1, sizeof(DevDesc)))) return 0;
if (!BMDeviceDriver(dev, devtable[type].gtype, filename, quality,
width, height, pointsize,
bgcolor, res, antialias, family, dpi)) {
free(dev);
error(_("unable to start device '%s'"), devtable[type].name);
}
gdd = GEcreateDevDesc(dev);
GEaddDevice2f(gdd, devtable[type].name, filename);
} END_SUSPEND_INTERRUPTS;
vmaxset(vmax);
return R_NilValue;
}
SEXP qt_qsetZValue(SEXP item, SEXP z)
{
unwrapQGraphicsItem(item, QGraphicsItem)->setZValue(asReal(z));
return item;
}
void VirtualValue::real2int()
{
ASSERT(isReal());
setNumber(static_cast<int>(asReal()));
}
SEXP qt_qsetVerticalSpacing_QGraphicsGridLayout(SEXP rself, SEXP rspacing) {
QGraphicsGridLayout *layout = unwrapPointer(rself, QGraphicsGridLayout);
layout->setVerticalSpacing(asReal(rspacing));
return rself;
}
/* This is a primitive SPECIALSXP with internal argument matching */
SEXP attribute_hidden do_rep(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, x, times = R_NilValue /* -Wall */;
int each = 1, nprotect = 3;
R_xlen_t i, lx, len = NA_INTEGER, nt;
static SEXP do_rep_formals = NULL;
/* includes factors, POSIX[cl]t, Date */
if (DispatchOrEval(call, op, R_RepCharSXP, args, rho, &ans, 0, 0))
return(ans);
/* This has evaluated all the non-missing arguments into ans */
PROTECT(args = ans);
/* This is a primitive, and we have not dispatched to a method
so we manage the argument matching ourselves. We pretend this is
rep(x, times, length.out, each, ...)
*/
if (do_rep_formals == NULL) {
do_rep_formals = CONS(R_NilValue, list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue));
R_PreserveObject(do_rep_formals);
SET_TAG(do_rep_formals, R_XSymbol);
SET_TAG(CDR(do_rep_formals), install("times"));
SET_TAG(CDDR(do_rep_formals), R_LengthOutSymbol);
SET_TAG(CDR(CDDR(do_rep_formals)), install("each"));
SET_TAG(CDDR(CDDR(do_rep_formals)), R_DotsSymbol);
}
PROTECT(args = matchArgs(do_rep_formals, args, call));
x = CAR(args);
/* supported in R 2.15.x */
if (TYPEOF(x) == LISTSXP)
errorcall(call, "replication of pairlists is defunct");
lx = xlength(x);
double slen = asReal(CADDR(args));
if (R_FINITE(slen)) {
if(slen < 0)
errorcall(call, _("invalid '%s' argument"), "length.out");
len = (R_xlen_t) slen;
} else {
len = asInteger(CADDR(args));
if(len != NA_INTEGER && len < 0)
errorcall(call, _("invalid '%s' argument"), "length.out");
}
if(length(CADDR(args)) != 1)
warningcall(call, _("first element used of '%s' argument"),
"length.out");
each = asInteger(CADDDR(args));
if(each != NA_INTEGER && each < 0)
errorcall(call, _("invalid '%s' argument"), "each");
if(length(CADDDR(args)) != 1)
warningcall(call, _("first element used of '%s' argument"), "each");
if(each == NA_INTEGER) each = 1;
if(lx == 0) {
if(len > 0 && x == R_NilValue)
warningcall(call, "'x' is NULL so the result will be NULL");
SEXP a;
PROTECT(a = duplicate(x));
if(len != NA_INTEGER && len > 0) a = xlengthgets(a, len);
UNPROTECT(3);
return a;
}
if (!isVector(x))
errorcall(call, "attempt to replicate an object of type '%s'",
type2char(TYPEOF(x)));
/* So now we know x is a vector of positive length. We need to
replicate it, and its names if it has them. */
/* First find the final length using 'times' and 'each' */
if(len != NA_INTEGER) { /* takes precedence over times */
nt = 1;
} else {
R_xlen_t sum = 0;
if(CADR(args) == R_MissingArg) PROTECT(times = ScalarInteger(1));
else PROTECT(times = coerceVector(CADR(args), INTSXP));
nprotect++;
nt = XLENGTH(times);
if(nt != 1 && nt != lx * each)
errorcall(call, _("invalid '%s' argument"), "times");
if(nt == 1) {
int it = INTEGER(times)[0];
if (it == NA_INTEGER || it < 0)
errorcall(call, _("invalid '%s' argument"), "times");
len = lx * it * each;
} else {
for(i = 0; i < nt; i++) {
int it = INTEGER(times)[i];
if (it == NA_INTEGER || it < 0)
errorcall(call, _("invalid '%s' argument"), "times");
sum += it;
}
len = sum;
}
}
if(len > 0 && each == 0)
errorcall(call, _("invalid '%s' argument"), "each");
SEXP xn = getNamesAttrib(x);
PROTECT(ans = rep4(x, times, len, each, nt));
if (length(xn) > 0)
setAttrib(ans, R_NamesSymbol, rep4(xn, times, len, each, nt));
#ifdef _S4_rep_keepClass
if(IS_S4_OBJECT(x)) { /* e.g. contains = "list" */
setAttrib(ans, R_ClassSymbol, getClassAttrib(x));
SET_S4_OBJECT(ans);
}
#endif
UNPROTECT(nprotect);
return ans;
}
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;
}
/* to match seq.default */
SEXP attribute_hidden do_seq(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans = R_NilValue /* -Wall */, tmp, from, to, by, len, along;
int nargs = length(args), lf;
Rboolean One = nargs == 1;
R_xlen_t i, lout = NA_INTEGER;
static SEXP do_seq_formals = NULL;
if (DispatchOrEval(call, op, R_SeqCharSXP, args, rho, &ans, 0, 1))
return(ans);
/* This is a primitive and we manage argument matching ourselves.
We pretend this is
seq(from, to, by, length.out, along.with, ...)
*/
if (do_seq_formals == NULL) {
do_seq_formals = CONS(R_NilValue, CONS(R_NilValue, list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue)));
R_PreserveObject(do_seq_formals);
tmp = do_seq_formals;
SET_TAG(tmp, install("from")); tmp = CDR(tmp);
SET_TAG(tmp, install("to")); tmp = CDR(tmp);
SET_TAG(tmp, install("by")); tmp = CDR(tmp);
SET_TAG(tmp, R_LengthOutSymbol); tmp = CDR(tmp);
SET_TAG(tmp, R_AlongWithSymbol); tmp = CDR(tmp);
SET_TAG(tmp, R_DotsSymbol);
}
PROTECT(args = matchArgs(do_seq_formals, args, call));
from = CAR(args); args = CDR(args);
to = CAR(args); args = CDR(args);
by = CAR(args); args = CDR(args);
len = CAR(args); args = CDR(args);
along = CAR(args);
if(One && from != R_MissingArg) {
lf = length(from);
if(lf == 1 && (TYPEOF(from) == INTSXP || TYPEOF(from) == REALSXP)) {
double rfrom = asReal(from);
if (!R_FINITE(rfrom))
errorcall(call, "'from' cannot be NA, NaN or infinite");
ans = seq_colon(1.0, rfrom, call);
}
else if (lf)
ans = seq_colon(1.0, (double)lf, call);
else
ans = allocVector(INTSXP, 0);
goto done;
}
if(along != R_MissingArg) {
lout = XLENGTH(along);
if(One) {
ans = lout ? seq_colon(1.0, (double)lout, call) : allocVector(INTSXP, 0);
goto done;
}
} else if(len != R_MissingArg && len != R_NilValue) {
double rout = asReal(len);
if(ISNAN(rout) || rout <= -0.5)
errorcall(call, _("'length.out' must be a non-negative number"));
if(length(len) != 1)
warningcall(call, _("first element used of '%s' argument"),
"length.out");
lout = (R_xlen_t) ceil(rout);
}
if(lout == NA_INTEGER) {
double rfrom = asReal(from), rto = asReal(to), rby = asReal(by), *ra;
if(from == R_MissingArg) rfrom = 1.0;
else if(length(from) != 1) error("'from' must be of length 1");
if(to == R_MissingArg) rto = 1.0;
else if(length(to) != 1) error("'to' must be of length 1");
if (!R_FINITE(rfrom))
errorcall(call, "'from' cannot be NA, NaN or infinite");
if (!R_FINITE(rto))
errorcall(call, "'to' cannot be NA, NaN or infinite");
if(by == R_MissingArg)
ans = seq_colon(rfrom, rto, call);
else {
if(length(by) != 1) error("'by' must be of length 1");
double del = rto - rfrom, n, dd;
R_xlen_t nn;
if(!R_FINITE(rfrom))
errorcall(call, _("'from' must be finite"));
if(!R_FINITE(rto))
errorcall(call, _("'to' must be finite"));
if(del == 0.0 && rto == 0.0) {
ans = to;
goto done;
}
/* printf("from = %f, to = %f, by = %f\n", rfrom, rto, rby); */
n = del/rby;
if(!R_FINITE(n)) {
if(del == 0.0 && rby == 0.0) {
ans = from;
goto done;
} else
errorcall(call, _("invalid '(to - from)/by' in 'seq'"));
}
dd = fabs(del)/fmax2(fabs(rto), fabs(rfrom));
if(dd < 100 * DBL_EPSILON) {
ans = from;
goto done;
}
#ifdef LONG_VECTOR_SUPPORT
if(n > 100 * (double) INT_MAX)
#else
if(n > (double) INT_MAX)
#endif
errorcall(call, _("'by' argument is much too small"));
if(n < - FEPS)
errorcall(call, _("wrong sign in 'by' argument"));
if(TYPEOF(from) == INTSXP &&
TYPEOF(to) == INTSXP &&
TYPEOF(by) == INTSXP) {
int *ia, ifrom = asInteger(from), iby = asInteger(by);
/* With the current limits on integers and FEPS
reduced below 1/INT_MAX this is the same as the
next, so this is future-proofing against longer integers.
*/
/* seq.default gives integer result from
from + (0:n)*by
*/
nn = (R_xlen_t) n;
ans = allocVector(INTSXP, nn+1);
ia = INTEGER(ans);
for(i = 0; i <= nn; i++)
ia[i] = (int)(ifrom + i * iby);
} else {
nn = (int)(n + FEPS);
ans = allocVector(REALSXP, nn+1);
ra = REAL(ans);
for(i = 0; i <= nn; i++)
ra[i] = rfrom + (double)i * rby;
/* Added in 2.9.0 */
if (nn > 0)
if((rby > 0 && ra[nn] > rto) || (rby < 0 && ra[nn] < rto))
ra[nn] = rto;
}
}
} else if (lout == 0) {
ans = allocVector(INTSXP, 0);
} else if (One) {
ans = seq_colon(1.0, (double)lout, call);
} else if (by == R_MissingArg) {
double rfrom = asReal(from), rto = asReal(to), rby;
if(to == R_MissingArg) rto = rfrom + (double)lout - 1;
if(from == R_MissingArg) rfrom = rto - (double)lout + 1;
if(!R_FINITE(rfrom))
errorcall(call, _("'from' must be finite"));
if(!R_FINITE(rto))
errorcall(call, _("'to' must be finite"));
ans = allocVector(REALSXP, lout);
if(lout > 0) REAL(ans)[0] = rfrom;
if(lout > 1) REAL(ans)[lout - 1] = rto;
if(lout > 2) {
rby = (rto - rfrom)/(double)(lout - 1);
for(i = 1; i < lout-1; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
REAL(ans)[i] = rfrom + (double)i*rby;
}
}
} else if (to == R_MissingArg) {
double rfrom = asReal(from), rby = asReal(by), rto;
if(from == R_MissingArg) rfrom = 1.0;
if(!R_FINITE(rfrom))
errorcall(call, _("'from' must be finite"));
if(!R_FINITE(rby))
errorcall(call, _("'by' must be finite"));
rto = rfrom + (double)(lout-1)*rby;
if(rby == (int)rby && rfrom <= INT_MAX && rfrom >= INT_MIN
&& rto <= INT_MAX && rto >= INT_MIN) {
ans = allocVector(INTSXP, lout);
for(i = 0; i < lout; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
INTEGER(ans)[i] = (int)(rfrom + (double)i*rby);
}
} else {
ans = allocVector(REALSXP, lout);
for(i = 0; i < lout; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
REAL(ans)[i] = rfrom + (double)i*rby;
}
}
} else if (from == R_MissingArg) {
double rto = asReal(to), rby = asReal(by),
rfrom = rto - (double)(lout-1)*rby;
if(!R_FINITE(rto))
errorcall(call, _("'to' must be finite"));
if(!R_FINITE(rby))
errorcall(call, _("'by' must be finite"));
if(rby == (int)rby && rfrom <= INT_MAX && rfrom >= INT_MIN
&& rto <= INT_MAX && rto >= INT_MIN) {
ans = allocVector(INTSXP, lout);
for(i = 0; i < lout; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
INTEGER(ans)[i] = (int)(rto - (double)(lout - 1 - i)*rby);
}
} else {
ans = allocVector(REALSXP, lout);
for(i = 0; i < lout; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
REAL(ans)[i] = rto - (double)(lout - 1 - i)*rby;
}
}
} else
errorcall(call, _("too many arguments"));
done:
UNPROTECT(1);
return ans;
}
SEXP na_locf (SEXP x, SEXP fromLast, SEXP _maxgap, SEXP _limit)
{
/* only works on univariate data *
* of type LGLSXP, INTSXP and REALSXP. */
SEXP result;
int i, ii, nr, _first, P=0;
double gap, maxgap, limit;
_first = firstNonNA(x);
if(_first == nrows(x))
return(x);
int *int_x=NULL, *int_result=NULL;
double *real_x=NULL, *real_result=NULL;
if(ncols(x) > 1)
error("na.locf.xts only handles univariate, dimensioned data");
nr = nrows(x);
maxgap = asReal(coerceVector(_maxgap,REALSXP));
limit = asReal(coerceVector(_limit ,REALSXP));
gap = 0;
PROTECT(result = allocVector(TYPEOF(x), nrows(x))); P++;
switch(TYPEOF(x)) {
case LGLSXP:
int_x = LOGICAL(x);
int_result = LOGICAL(result);
if(!LOGICAL(fromLast)[0]) {
/* copy leading NAs */
for(i=0; i < (_first+1); i++) {
int_result[i] = int_x[i];
}
/* result[_first] now has first value fromLast=FALSE */
for(i=_first+1; i<nr; i++) {
int_result[i] = int_x[i];
if(int_result[i] == NA_LOGICAL && gap < maxgap) {
int_result[i] = int_result[i-1];
gap++;
}
}
if((int)gap > (int)maxgap) { /* check that we don't have excessive trailing gap */
for(ii = i-1; ii > i-gap-1; ii--) {
int_result[ii] = NA_LOGICAL;
}
}
} else {
/* nr-2 is first position to fill fromLast=TRUE */
int_result[nr-1] = int_x[nr-1];
for(i=nr-2; i>=0; i--) {
int_result[i] = int_x[i];
if(int_result[i] == NA_LOGICAL && gap < maxgap) {
int_result[i] = int_result[i+1];
gap++;
}
}
}
break;
case INTSXP:
int_x = INTEGER(x);
int_result = INTEGER(result);
if(!LOGICAL(fromLast)[0]) {
/* copy leading NAs */
for(i=0; i < (_first+1); i++) {
int_result[i] = int_x[i];
}
/* result[_first] now has first value fromLast=FALSE */
for(i=_first+1; i<nr; i++) {
int_result[i] = int_x[i];
if(int_result[i] == NA_INTEGER) {
if(limit > gap)
int_result[i] = int_result[i-1];
gap++;
} else {
if((int)gap > (int)maxgap) {
for(ii = i-1; ii > i-gap-1; ii--) {
int_result[ii] = NA_INTEGER;
}
}
gap=0;
}
}
if((int)gap > (int)maxgap) { /* check that we don't have excessive trailing gap */
for(ii = i-1; ii > i-gap-1; ii--) {
int_result[ii] = NA_INTEGER;
}
}
} else {
/* nr-2 is first position to fill fromLast=TRUE */
int_result[nr-1] = int_x[nr-1];
for(i=nr-2; i>=0; i--) {
int_result[i] = int_x[i];
if(int_result[i] == NA_INTEGER) {
if(limit > gap)
int_result[i] = int_result[i+1];
gap++;
} else {
if((int)gap > (int)maxgap) {
for(ii = i+1; ii < i+gap+1; ii++) {
int_result[ii] = NA_INTEGER;
}
}
gap=0;
}
}
if((int)gap > (int)maxgap) { /* check that we don't have leading trailing gap */
for(ii = i+1; ii < i+gap+1; ii++) {
int_result[ii] = NA_INTEGER;
}
}
}
break;
case REALSXP:
real_x = REAL(x);
real_result = REAL(result);
if(!LOGICAL(fromLast)[0]) { /* fromLast=FALSE */
for(i=0; i < (_first+1); i++) {
real_result[i] = real_x[i];
}
for(i=_first+1; i<nr; i++) {
real_result[i] = real_x[i];
if( ISNA(real_result[i]) || ISNAN(real_result[i])) {
if(limit > gap)
real_result[i] = real_result[i-1];
gap++;
} else {
if((int)gap > (int)maxgap) {
for(ii = i-1; ii > i-gap-1; ii--) {
real_result[ii] = NA_REAL;
}
}
gap=0;
}
}
if((int)gap > (int)maxgap) { /* check that we don't have excessive trailing gap */
for(ii = i-1; ii > i-gap-1; ii--) {
real_result[ii] = NA_REAL;
}
}
} else { /* fromLast=TRUE */
real_result[nr-1] = real_x[nr-1];
for(i=nr-2; i>=0; i--) {
real_result[i] = real_x[i];
if(ISNA(real_result[i]) || ISNAN(real_result[i])) {
if(limit > gap)
real_result[i] = real_result[i+1];
gap++;
} else {
if((int)gap > (int)maxgap) {
for(ii = i+1; ii < i+gap+1; ii++) {
real_result[ii] = NA_REAL;
}
}
gap=0;
}
}
if((int)gap > (int)maxgap) { /* check that we don't have leading trailing gap */
for(ii = i+1; ii < i+gap+1; ii++) {
real_result[ii] = NA_REAL;
}
}
}
break;
default:
error("unsupported type");
break;
}
if(isXts(x)) {
setAttrib(result, R_DimSymbol, getAttrib(x, R_DimSymbol));
setAttrib(result, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol));
setAttrib(result, xts_IndexSymbol, getAttrib(x, xts_IndexSymbol));
copy_xtsCoreAttributes(x, result);
copy_xtsAttributes(x, result);
}
UNPROTECT(P);
return(result);
}
SEXP Cdqrls(SEXP x, SEXP y, SEXP tol)
{
SEXP ans, ansnames;
SEXP qr, coefficients, residuals, effects, pivot, qraux;
int n, ny = 0, p, rank, nprotect = 4, pivoted = 0;
double rtol = asReal(tol), *work;
int *dims = INTEGER(getAttrib(x, R_DimSymbol));
n = dims[0]; p = dims[1];
if(n) ny = LENGTH(y)/n; /* n x ny, or a vector */
/* 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 'x'");
rptr = REAL(y);
for (R_xlen_t i = 0 ; i < XLENGTH(y) ; i++)
if(!R_FINITE(rptr[i])) error("NA/NaN/Inf in 'y'");
PROTECT(ans = allocVector(VECSXP, 9));
ansnames = allocVector(STRSXP, 9);
setAttrib(ans, R_NamesSymbol, ansnames);
SET_STRING_ELT(ansnames, 0, mkChar("qr"));
SET_STRING_ELT(ansnames, 1, mkChar("coefficients"));
SET_STRING_ELT(ansnames, 2, mkChar("residuals"));
SET_STRING_ELT(ansnames, 3, mkChar("effects"));
SET_STRING_ELT(ansnames, 4, mkChar("rank"));
SET_STRING_ELT(ansnames, 5, mkChar("pivot"));
SET_STRING_ELT(ansnames, 6, mkChar("qraux"));
SET_STRING_ELT(ansnames, 7, mkChar("tol"));
SET_STRING_ELT(ansnames, 8, mkChar("pivoted"));
SET_VECTOR_ELT(ans, 0, qr = duplicate(x));
if (ny > 1) coefficients = allocMatrix(REALSXP, p, ny);
else coefficients = 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
KalmanSmooth(SEXP sy, SEXP sZ, SEXP sa, SEXP sP, SEXP sT,
SEXP sV, SEXP sh, SEXP sPn, SEXP sUP)
{
SEXP ssa, ssP, ssPn, res, states = R_NilValue, sN;
double resid0, gain, tmp, *anew, *mm, *M;
double *at, *rt, *Pt, *gains, *resids, *Mt, *L, gn, *Nt;
int i, j, k, l;
Rboolean var = TRUE;
if (TYPEOF(sy) != REALSXP || TYPEOF(sZ) != REALSXP ||
TYPEOF(sa) != REALSXP || TYPEOF(sP) != REALSXP ||
TYPEOF(sT) != REALSXP || TYPEOF(sV) != REALSXP)
error(_("invalid argument type"));
int n = LENGTH(sy), p = LENGTH(sa);
double *y = REAL(sy), *Z = REAL(sZ), *a, *P,
*T = REAL(sT), *V = REAL(sV), h = asReal(sh), *Pnew;
PROTECT(ssa = duplicate(sa)); a = REAL(ssa);
PROTECT(ssP = duplicate(sP)); P = REAL(ssP);
PROTECT(ssPn = duplicate(sPn)); Pnew = REAL(ssPn);
PROTECT(res = allocVector(VECSXP, 2));
SET_VECTOR_ELT(res, 0, states = allocMatrix(REALSXP, n, p));
at = REAL(states);
SET_VECTOR_ELT(res, 1, sN = allocVector(REALSXP, n*p*p));
Nt = REAL(sN);
anew = (double *) R_alloc(p, sizeof(double));
M = (double *) R_alloc(p, sizeof(double));
mm = (double *) R_alloc(p * p, sizeof(double));
Pt = (double *) R_alloc(n * p * p, sizeof(double));
gains = (double *) R_alloc(n, sizeof(double));
resids = (double *) R_alloc(n, sizeof(double));
Mt = (double *) R_alloc(n * p, sizeof(double));
L = (double *) R_alloc(p * p, sizeof(double));
for (l = 0; l < n; l++) {
for (i = 0; i < p; i++) {
tmp = 0.0;
for (k = 0; k < p; k++)
tmp += T[i + p * k] * a[k];
anew[i] = tmp;
}
if (l > asInteger(sUP)) {
for (i = 0; i < p; i++)
for (j = 0; j < p; j++) {
tmp = 0.0;
for (k = 0; k < p; k++)
tmp += T[i + p * k] * P[k + p * j];
mm[i + p * j] = tmp;
}
for (i = 0; i < p; i++)
for (j = 0; j < p; j++) {
tmp = V[i + p * j];
for (k = 0; k < p; k++)
tmp += mm[i + p * k] * T[j + p * k];
Pnew[i + p * j] = tmp;
}
}
for (i = 0; i < p; i++) at[l + n*i] = anew[i];
for (i = 0; i < p*p; i++) Pt[l + n*i] = Pnew[i];
if (!ISNAN(y[l])) {
resid0 = y[l];
for (i = 0; i < p; i++)
resid0 -= Z[i] * anew[i];
gain = h;
for (i = 0; i < p; i++) {
tmp = 0.0;
for (j = 0; j < p; j++)
tmp += Pnew[i + j * p] * Z[j];
Mt[l + n*i] = M[i] = tmp;
gain += Z[i] * M[i];
}
gains[l] = gain;
resids[l] = resid0;
for (i = 0; i < p; i++)
a[i] = anew[i] + M[i] * resid0 / gain;
for (i = 0; i < p; i++)
for (j = 0; j < p; j++)
P[i + j * p] = Pnew[i + j * p] - M[i] * M[j] / gain;
} else {
for (i = 0; i < p; i++) {
a[i] = anew[i];
Mt[l + n * i] = 0.0;
}
for (i = 0; i < p * p; i++)
P[i] = Pnew[i];
gains[l] = NA_REAL;
resids[l] = NA_REAL;
}
}
/* rt stores r_{t-1} */
rt = (double *) R_alloc(n * p, sizeof(double));
for (l = n - 1; l >= 0; l--) {
if (!ISNAN(gains[l])) {
gn = 1/gains[l];
for (i = 0; i < p; i++)
rt[l + n * i] = Z[i] * resids[l] * gn;
} else {
for (i = 0; i < p; i++) rt[l + n * i] = 0.0;
gn = 0.0;
}
if (var) {
for (i = 0; i < p; i++)
for (j = 0; j < p; j++)
Nt[l + n*i + n*p*j] = Z[i] * Z[j] * gn;
}
if (l < n - 1) {
/* compute r_{t-1} */
for (i = 0; i < p; i++)
for (j = 0; j < p; j++)
mm[i + p * j] = ((i==j)?1:0) - Mt[l + n * i] * Z[j] * gn;
for (i = 0; i < p; i++)
for (j = 0; j < p; j++) {
tmp = 0.0;
for (k = 0; k < p; k++)
tmp += T[i + p * k] * mm[k + p * j];
L[i + p * j] = tmp;
}
for (i = 0; i < p; i++) {
tmp = 0.0;
for (j = 0; j < p; j++)
tmp += L[j + p * i] * rt[l + 1 + n * j];
rt[l + n * i] += tmp;
}
if(var) { /* compute N_{t-1} */
for (i = 0; i < p; i++)
for (j = 0; j < p; j++) {
tmp = 0.0;
for (k = 0; k < p; k++)
tmp += L[k + p * i] * Nt[l + 1 + n*k + n*p*j];
mm[i + p * j] = tmp;
}
for (i = 0; i < p; i++)
for (j = 0; j < p; j++) {
tmp = 0.0;
for (k = 0; k < p; k++)
tmp += mm[i + p * k] * L[k + p * j];
Nt[l + n*i + n*p*j] += tmp;
}
}
}
for (i = 0; i < p; i++) {
tmp = 0.0;
for (j = 0; j < p; j++)
tmp += Pt[l + n*i + n*p*j] * rt[l + n * j];
at[l + n*i] += tmp;
}
}
if (var)
for (l = 0; l < n; l++) {
for (i = 0; i < p; i++)
for (j = 0; j < p; j++) {
tmp = 0.0;
for (k = 0; k < p; k++)
tmp += Pt[l + n*i + n*p*k] * Nt[l + n*k + n*p*j];
mm[i + p * j] = tmp;
}
for (i = 0; i < p; i++)
for (j = 0; j < p; j++) {
tmp = Pt[l + n*i + n*p*j];
for (k = 0; k < p; k++)
tmp -= mm[i + p * k] * Pt[l + n*k + n*p*j];
Nt[l + n*i + n*p*j] = tmp;
}
}
UNPROTECT(4);
return res;
}
SEXP prob_profit ( SEXP beg, SEXP end, SEXP lsp,
SEXP horizon, SEXP sample )
{
/* Arguments:
* beg First permutation index value
* end Last permutation index value
* val Profit target (percent)
* horizon Horizon over which to determine probability
* hpr Holding period returns
* prob Probability of each HPR
* sample If sample=0, run all permutations
* else run 'end - beg' random permutations
* replace boolean (not implemented, always replace)
*/
int P=0; /* PROTECT counter */
int i, j; /* loop counters */
/* extract lsp components */
//double *d_event = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 0)))); P++;
double *d_prob = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 1)))); P++;
//double *d_fval = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 2)))); P++;
//double *d_maxloss = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 3)))); P++;
double *d_zval = REAL(PROTECT(AS_NUMERIC(VECTOR_ELT(lsp, 4)))); P++;
/* Get values from pointers */
double i_beg = asReal(beg)-1; /* zero-based */
double i_end = asReal(end)-1; /* zero-based */
double i_sample = asReal(sample);
int i_horizon = asInteger(horizon);
/* initialize result object and pointer */
SEXP result;
PROTECT(result = allocVector(REALSXP, 2)); P++;
double *d_result = REAL(result);
/* initialize portfolio HPR object */
SEXP phpr;
double I; int J;
double nr = nrows(VECTOR_ELT(lsp, 1));
double passProb = 0;
double sumProb = 0;
double *d_phpr = NULL;
/* does the lsp object have non-zero z values? */
int using_z = (d_zval[0]==0 && d_zval[1]==0) ? 0 : 1;
/* initialize object to hold permutation locations */
SEXP perm;
PROTECT(perm = allocVector(INTSXP, i_horizon)); P++;
int *i_perm = INTEGER(perm);
/* if lsp object contains z-values of zero, calculate HPR before
* running permutations */
if( !using_z ) {
PROTECT(phpr = hpr(lsp, ScalarLogical(TRUE), R_NilValue)); P++;
d_phpr = REAL(phpr);
}
/* Initialize R's random number generator (read in .Random.seed) */
if(i_sample > 0) GetRNGstate();
double probPerm; /* proability of this permutation */
double t0hpr; /* this period's (t = 0) HPR */
double t1hpr; /* last period's (t = 1) HPR */
double target = 1+d_zval[2];
/* Loop over each permutation index */
for(i=i_beg; i<=i_end; i++) {
/* check for user-requested interrupt */
if( i % 10000 == 999 ) R_CheckUserInterrupt();
probPerm = 1; /* proability of this permutation */
t0hpr = 1; /* this period's (t = 0) HPR */
t1hpr = 1; /* last period's (t = 1) HPR */
/* if sampling, get a random permutation between 0 and nPr-1,
* else use the current index value. */
I = (i_sample > 0) ? ( unif_rand() * (i_sample-1) ) : i;
/* set the permutation locations for index 'I' */
for(j=i_horizon; j--;) {
i_perm[j] = (long)fmod(I/pow(nr,j),nr);
}
/* Keep track of this permutation's probability */
for(j=i_horizon; j--;) {
probPerm *= d_prob[i_perm[j]];
}
/* if lsp object contains non-zero z values, calculate HPR for
* each permutation */
if( using_z ) {
/* call lspm::hpr and assign pointer */
PROTECT(phpr = hpr(lsp, ScalarLogical(TRUE), perm));
d_phpr = REAL(phpr);
}
/* loop over permutation locations */
for(j=0; j<i_horizon; j++) {
/* if using_z, phpr has 'i_horizon' elements, else it has
* 'nr' elements */
J = using_z ? j : i_perm[j];
t1hpr *= d_phpr[J]; /* New portfolio balance */
}
if( using_z ) UNPROTECT(1); /* UNPROTECT phpr */
/* If this permutation hit its target return,
* add its probability to the total. */
if( t1hpr >= target ) {
passProb += probPerm;
}
/* Total probability of all permutations */
sumProb += probPerm;
}
if(i_sample > 0) PutRNGstate(); /* Write out .Random.seed */
/* Store results */
d_result[0] = passProb;
d_result[1] = sumProb;
UNPROTECT(P);
return result;
}
/* y vector length n of observations
Z vector length p for observation equation y_t = Za_t + eps_t
a vector length p of initial state
P p x p matrix for initial state uncertainty (contemparaneous)
T p x p transition matrix
V p x p = RQR'
h = var(eps_t)
anew used for a[t|t-1]
Pnew used for P[t|t -1]
M used for M = P[t|t -1]Z
No checking here!
*/
SEXP
KalmanLike(SEXP sy, SEXP sZ, SEXP sa, SEXP sP, SEXP sT,
SEXP sV, SEXP sh, SEXP sPn, SEXP sUP, SEXP op, SEXP fast)
{
SEXP res, ans = R_NilValue, resid = R_NilValue, states = R_NilValue;
int n, p, lop = asLogical(op);
double *y, *Z, *a, *P, *T, *V, h = asReal(sh), *Pnew;
double sumlog = 0.0, ssq = 0, resid0, gain, tmp, *anew, *mm, *M;
int i, j, k, l;
if (TYPEOF(sy) != REALSXP || TYPEOF(sZ) != REALSXP ||
TYPEOF(sa) != REALSXP || TYPEOF(sP) != REALSXP ||
TYPEOF(sPn) != REALSXP ||
TYPEOF(sT) != REALSXP || TYPEOF(sV) != REALSXP)
error(_("invalid argument type"));
n = LENGTH(sy); p = LENGTH(sa);
y = REAL(sy); Z = REAL(sZ); T = REAL(sT); V = REAL(sV);
/* Avoid modifying arguments unless fast=TRUE */
if (!LOGICAL(fast)[0]){
PROTECT(sP = duplicate(sP));
PROTECT(sa = duplicate(sa));
PROTECT(sPn = duplicate(sPn));
}
P = REAL(sP); a = REAL(sa); Pnew = REAL(sPn);
anew = (double *) R_alloc(p, sizeof(double));
M = (double *) R_alloc(p, sizeof(double));
mm = (double *) R_alloc(p * p, sizeof(double));
if(lop) {
PROTECT(ans = allocVector(VECSXP, 3));
SET_VECTOR_ELT(ans, 1, resid = allocVector(REALSXP, n));
SET_VECTOR_ELT(ans, 2, states = allocMatrix(REALSXP, n, p));
}
for (l = 0; l < n; l++) {
for (i = 0; i < p; i++) {
tmp = 0.0;
for (k = 0; k < p; k++)
tmp += T[i + p * k] * a[k];
anew[i] = tmp;
}
if (l > asInteger(sUP)) {
for (i = 0; i < p; i++)
for (j = 0; j < p; j++) {
tmp = 0.0;
for (k = 0; k < p; k++)
tmp += T[i + p * k] * P[k + p * j];
mm[i + p * j] = tmp;
}
for (i = 0; i < p; i++)
for (j = 0; j < p; j++) {
tmp = V[i + p * j];
for (k = 0; k < p; k++)
tmp += mm[i + p * k] * T[j + p * k];
Pnew[i + p * j] = tmp;
}
}
if (!ISNAN(y[l])) {
double *rr = NULL /* -Wall */;
if(lop) rr = REAL(resid);
resid0 = y[l];
for (i = 0; i < p; i++)
resid0 -= Z[i] * anew[i];
gain = h;
for (i = 0; i < p; i++) {
tmp = 0.0;
for (j = 0; j < p; j++)
tmp += Pnew[i + j * p] * Z[j];
M[i] = tmp;
gain += Z[i] * M[i];
}
ssq += resid0 * resid0 / gain;
if(lop) rr[l] = resid0 / sqrt(gain);
sumlog += log(gain);
for (i = 0; i < p; i++)
a[i] = anew[i] + M[i] * resid0 / gain;
for (i = 0; i < p; i++)
for (j = 0; j < p; j++)
P[i + j * p] = Pnew[i + j * p] - M[i] * M[j] / gain;
} else {
double *rr = NULL /* -Wall */;
if(lop) rr = REAL(resid);
for (i = 0; i < p; i++)
a[i] = anew[i];
for (i = 0; i < p * p; i++)
P[i] = Pnew[i];
if(lop) rr[l] = NA_REAL;
}
if(lop) {
double *rs = REAL(states);
for(j = 0; j < p; j++) rs[l + n*j] = a[j];
}
}
if(lop) {
SET_VECTOR_ELT(ans, 0, res=allocVector(REALSXP, 2));
REAL(res)[0] = ssq; REAL(res)[1] = sumlog;
UNPROTECT(1);
if (!LOGICAL(fast)[0])
UNPROTECT(3);
return ans;
} else {
res = allocVector(REALSXP, 2);
REAL(res)[0] = ssq; REAL(res)[1] = sumlog;
if (!LOGICAL(fast)[0])
UNPROTECT(3);
return res;
}
}
/*
* call to nls_iter from R --- .Call("nls_iter", m, control, doTrace)
* where m and control are nlsModel and nlsControl objects
* doTrace is a logical value.
* m is modified; the return value is a "convergence-information" list.
*/
SEXP
nls_iter(SEXP m, SEXP control, SEXP doTraceArg)
{
double dev, fac, minFac, tolerance, newDev, convNew = -1./*-Wall*/;
int i, j, maxIter, hasConverged, nPars, doTrace, evaltotCnt = -1, warnOnly, printEval;
SEXP tmp, conv, incr, deviance, setPars, getPars, pars, newPars, trace;
doTrace = asLogical(doTraceArg);
if(!isNewList(control))
error(_("'control' must be a list"));
if(!isNewList(m))
error(_("'m' must be a list"));
PROTECT(tmp = getAttrib(control, R_NamesSymbol));
conv = getListElement(control, tmp, "maxiter");
if(conv == NULL || !isNumeric(conv))
error(_("'%s' absent"), "control$maxiter");
maxIter = asInteger(conv);
conv = getListElement(control, tmp, "tol");
if(conv == NULL || !isNumeric(conv))
error(_("'%s' absent"), "control$tol");
tolerance = asReal(conv);
conv = getListElement(control, tmp, "minFactor");
if(conv == NULL || !isNumeric(conv))
error(_("'%s' absent"), "control$minFactor");
minFac = asReal(conv);
conv = getListElement(control, tmp, "warnOnly");
if(conv == NULL || !isLogical(conv))
error(_("'%s' absent"), "control$warnOnly");
warnOnly = asLogical(conv);
conv = getListElement(control, tmp, "printEval");
if(conv == NULL || !isLogical(conv))
error(_("'%s' absent"), "control$printEval");
printEval = asLogical(conv);
#define CONV_INFO_MSG(_STR_, _I_) \
ConvInfoMsg(_STR_, i, _I_, fac, minFac, maxIter, convNew)
#define NON_CONV_FINIS(_ID_, _MSG_) \
if(warnOnly) { \
warning(_MSG_); \
return CONV_INFO_MSG(_MSG_, _ID_); \
} \
else \
error(_MSG_);
#define NON_CONV_FINIS_1(_ID_, _MSG_, _A1_) \
if(warnOnly) { \
char msgbuf[1000]; \
warning(_MSG_, _A1_); \
snprintf(msgbuf, 1000, _MSG_, _A1_); \
return CONV_INFO_MSG(msgbuf, _ID_); \
} \
else \
error(_MSG_, _A1_);
#define NON_CONV_FINIS_2(_ID_, _MSG_, _A1_, _A2_) \
if(warnOnly) { \
char msgbuf[1000]; \
warning(_MSG_, _A1_, _A2_); \
snprintf(msgbuf, 1000, _MSG_, _A1_, _A2_); \
return CONV_INFO_MSG(msgbuf, _ID_); \
} \
else \
error(_MSG_, _A1_, _A2_);
/* now get parts from 'm' */
tmp = getAttrib(m, R_NamesSymbol);
conv = getListElement(m, tmp, "conv");
if(conv == NULL || !isFunction(conv))
error(_("'%s' absent"), "m$conv()");
PROTECT(conv = lang1(conv));
incr = getListElement(m, tmp, "incr");
if(incr == NULL || !isFunction(incr))
error(_("'%s' absent"), "m$incr()");
PROTECT(incr = lang1(incr));
deviance = getListElement(m, tmp, "deviance");
if(deviance == NULL || !isFunction(deviance))
error(_("'%s' absent"), "m$deviance()");
PROTECT(deviance = lang1(deviance));
trace = getListElement(m, tmp, "trace");
if(trace == NULL || !isFunction(trace))
error(_("'%s' absent"), "m$trace()");
PROTECT(trace = lang1(trace));
setPars = getListElement(m, tmp, "setPars");
if(setPars == NULL || !isFunction(setPars))
error(_("'%s' absent"), "m$setPars()");
PROTECT(setPars);
getPars = getListElement(m, tmp, "getPars");
if(getPars == NULL || !isFunction(getPars))
error(_("'%s' absent"), "m$getPars()");
PROTECT(getPars = lang1(getPars));
PROTECT(pars = eval(getPars, R_GlobalEnv));
nPars = LENGTH(pars);
dev = asReal(eval(deviance, R_GlobalEnv));
if(doTrace) eval(trace,R_GlobalEnv);
fac = 1.0;
hasConverged = FALSE;
PROTECT(newPars = allocVector(REALSXP, nPars));
if(printEval)
evaltotCnt = 1;
for (i = 0; i < maxIter; i++) {
SEXP newIncr;
int evalCnt = -1;
if((convNew = asReal(eval(conv, R_GlobalEnv))) < tolerance) {
hasConverged = TRUE;
break;
}
PROTECT(newIncr = eval(incr, R_GlobalEnv));
if(printEval)
evalCnt = 1;
while(fac >= minFac) {
if(printEval) {
Rprintf(" It. %3d, fac= %11.6g, eval (no.,total): (%2d,%3d):",
i+1, fac, evalCnt, evaltotCnt);
evalCnt++;
evaltotCnt++;
}
for(j = 0; j < nPars; j++)
REAL(newPars)[j] = REAL(pars)[j] + fac * REAL(newIncr)[j];
PROTECT(tmp = lang2(setPars, newPars));
if (asLogical(eval(tmp, R_GlobalEnv))) { /* singular gradient */
UNPROTECT(11);
NON_CONV_FINIS(1, _("singular gradient"));
}
UNPROTECT(1);
newDev = asReal(eval(deviance, R_GlobalEnv));
if(printEval)
Rprintf(" new dev = %g\n", newDev);
if(newDev <= dev) {
dev = newDev;
fac = MIN(2*fac, 1);
tmp = newPars;
newPars = pars;
pars = tmp;
break;
}
fac /= 2.;
}
UNPROTECT(1);
if( fac < minFac ) {
UNPROTECT(9);
NON_CONV_FINIS_2(2,
_("step factor %g reduced below 'minFactor' of %g"),
fac, minFac);
}
if(doTrace) eval(trace, R_GlobalEnv);
}
UNPROTECT(9);
if(!hasConverged) {
NON_CONV_FINIS_1(3,
_("number of iterations exceeded maximum of %d"),
maxIter);
}
/* else */
return CONV_INFO_MSG(_("converged"), 0);
}
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, a copy is available at
* http://www.r-project.org/Licenses/
*/
/* Graphical parameters which are treated identically by
* par( <nam> = <value> ) and highlevel plotfun (..., <nam> = <value> ).
*
* This is #included both from Specify() and Specify2() into ./par.c
*/
if (streql(what, "adj")) {
lengthCheck(what, value, 1); x = asReal(value);
BoundsCheck(x, 0.0, 1.0, what);
R_DEV__(adj) = x;
}
else if (streql(what, "ann")) {
lengthCheck(what, value, 1); ix = asLogical(value);
R_DEV__(ann) = (ix != 0);/* NA |-> TRUE */
}
else if (streql(what, "bg")) {
/* in par() this means the plot region, inline it means filled points */
#ifdef FOR_PAR
lengthCheck(what, value, 1);
#else
if (!isVector(value) || LENGTH(value) < 1) par_error(what);
#endif
R_DEV__(bg) = RGBpar3(value, 0, dpptr(dd)->bg);
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);
}
SEXP swfDevice ( SEXP args ){
/*
* Make sure the version number of the R running this
* routine is compatible with the version number of
* the R that compiled this routine.
*/
R_GE_checkVersionOrDie(R_GE_version);
/* Declare local variabls for holding the components of the args SEXP */
const char *fileName;
const char *bg, *fg;
double width, height, frameRate;
SEXP fontFileList;
const char *logFileName;
/*
* pGEDevDesc is a variable provided by the R Graphics Engine
* that contains all device information required by the parent
* R system. It contains one important componant of type pDevDesc
* which containts information specific to the implementation of
* the swf device. The creation and initialization of this component
* is one of the main tasks of this routine.
*/
pGEDevDesc swfDev;
/* Retrieve function arguments from input SEXP. */
/*
* Skip first argument. It holds the name of the R function
* that called this C routine.
*/
args = CDR(args);
/* Recover file name. */
fileName = translateChar(asChar(CAR(args)));
/* Advance to next argument stored in SEXPR. */
args = CDR(args);
/* Recover figure dimensions. */
/* For now these are assumed to be in inches. */
width = asReal(CAR(args)); args = CDR(args);
height = asReal(CAR(args)); args = CDR(args);
/* Recover initial background and foreground colors. */
bg = CHAR(asChar(CAR(args))); args = CDR(args);
fg = CHAR(asChar(CAR(args))); args = CDR(args);
frameRate = asReal(asChar(CAR(args))); args = CDR(args);
fontFileList = CAR(args); args = CDR(args);
logFileName = CHAR(asChar(CAR(args))); args = CDR(args);
/* Ensure there is an empty slot avaliable for a new device. */
R_CheckDeviceAvailable();
BEGIN_SUSPEND_INTERRUPTS{
/*
* The pDevDesc variable specifies which funtions and components
* which describe the specifics of this graphics device. After
* setup, this information will be incorporated into the pGEDevDesc
* variable swfDev.
*/
pDevDesc deviceInfo;
/*
* Create the deviceInfo variable. If this operation fails,
* a 0 is returned in order to cause R to shut down due to the
* possibility of corrupted memory.
*/
if( !( deviceInfo = (pDevDesc) calloc(1, sizeof(DevDesc))) )
return 0;
/*
* Call setup routine to initialize deviceInfo and associate
* R graphics function hooks with the appropriate C routines
* in this file.
*/
if( !SWF_Setup( deviceInfo, fileName, width, height, bg, fg,
frameRate, fontFileList, logFileName ) ){
/*
* If setup was unsuccessful, destroy the device and return
* an error message.
*/
free( deviceInfo );
error("SWF device setup was unsuccessful!");
}
/* Create swfDev as a Graphics Engine device using deviceInfo. */
swfDev = GEcreateDevDesc( deviceInfo );
// Register the device as an avaiable graphics device in the R
// Session.
GEaddDevice2( swfDev, "swf output" );
} END_SUSPEND_INTERRUPTS;
return R_NilValue;
}
SEXP fitabn_marginals(SEXP R_obsdata, SEXP R_dag,SEXP R_numVars, SEXP R_vartype, SEXP R_maxparents,SEXP R_priors_mean, SEXP R_priors_sd,SEXP R_priors_gamshape,SEXP R_priors_gamscale,
SEXP R_maxiters, SEXP R_epsabs, SEXP R_verbose, SEXP R_errorverbose, SEXP R_groupedvars, SEXP R_groupids, SEXP R_epsabs_inner,SEXP R_maxiters_inner,
SEXP R_finitestepsize, SEXP R_hparams,
SEXP R_childid, SEXP R_paramid, SEXP R_denom_modes, SEXP R_betafixed, SEXP R_mlik, SEXP R_maxiters_hessian,
SEXP R_max_hessian_error,SEXP R_myfactor_brent, SEXP R_maxiters_hessian_brent, SEXP R_num_intervals_brent)
{
/** ****************/
/** declarations **/
int errverbose,verbose;
datamatrix data,designmatrix;
const double priormean=asReal(R_priors_mean);/*Rprintf("priormean=%f %f\n",priormean[0],priormean[5]);*/
const double priorsd=asReal(R_priors_sd);/*Rprintf("priorsd=%f %f\n",priorsd[0],priorsd[5]);*/
const double priorgamshape=asReal(R_priors_gamshape); /*Rprintf("priorgamshape=%f %f\n",priorgamshape[0],priorgamshape[1]);*/
const double priorgamscale=asReal(R_priors_gamscale); /*Rprintf("priorgamscale=%f %f\n",priorgamscale[0],priorgamscale[1]);*/
/*const int *vartype=INTEGER(R_vartype);*/
/*const int numvariates=asInteger(R_numvariates);*/
int numVars=asInteger(R_numVars);
double max_hessian_error=asReal(R_max_hessian_error);
double myfactor_brent=asReal(R_myfactor_brent);
int maxiters_hessian_brent=asInteger(R_maxiters_hessian_brent);
double num_intervals_brent=asReal(R_num_intervals_brent);
/*Rprintf("vartype: ");for(i=0;i<LENGTH(R_vartype);i++){Rprintf("%u ",vartype[i]);} Rprintf("\n");*/
network dag;
/*cycle cyclestore;*/
/*storage nodescore;*/
SEXP posterior;
double *denom_modes=REAL(R_denom_modes);
int childid=asInteger(R_childid);
int paramid=asInteger(R_paramid);
/** end of declarations*/
/** *******************/
/** ********************************************/
/** parse function arguments - R data structs **/
/** get the data we require from the passed arguments e.g. how many variables/nodes to we have **/
const int maxiters=asInteger(R_maxiters);
const double epsabs=asReal(R_epsabs);
int maxiters_inner=asInteger(R_maxiters_inner);
int maxiters_hessian=asInteger(R_maxiters_hessian);
double epsabs_inner=asReal(R_epsabs_inner);
const int maxparents=asInteger(R_maxparents);
double finitestepsize=asReal(R_finitestepsize);
/*double h_lowerend=REAL(R_hparams)[0];
double h_upperend=REAL(R_hparams)[1];*/
double h_guess=REAL(R_hparams)[0];
double h_epsabs=REAL(R_hparams)[1];
double betafixed=asReal(R_betafixed);
double mlik=asReal(R_mlik);
verbose=asInteger(R_verbose);
errverbose=asInteger(R_errorverbose);
/** end of argument parsing **/
/** *******************************************************************************
***********************************************************************************
STEP 0. - create R storage for sending results back */
/** generic code to create a list comprising of vectors of type double
- currently overkill but useful template **/
#ifdef JUNK
PROTECT(listresults = allocVector(VECSXP, 2));
for(i=0;i<2;i++){
PROTECT(tmplistentry=NEW_NUMERIC(numvariates));
SET_VECTOR_ELT(listresults, i, tmplistentry);
UNPROTECT(1);
}
#endif
/** *******************************************************************************
***********************************************************************************
STEP 1. convert data.frame in R into C data structure for us with BGM functions */
make_dag(&dag, numVars,R_dag,0,R_vartype,&maxparents,R_groupedvars);/** user supplied DAG **/
/*printDAG(&dag,2);*/
make_data(R_obsdata,&data,R_groupids);
#ifdef JUNK
/** An R MATRIX it is single dimension and just needs to be unrolled */
posterior=gsl_matrix_alloc(numvariates,2);
for(j=0;j<2;j++){for(i=0;i<numvariates;i++){gsl_matrix_set(posterior,i,j,REAL(R_posterior)[i+j*numvariates]);}}
#endif
/*gsl_set_error_handler_off();*//*Rprintf("Warning: turning off GSL Error handler\n"); */
/*calc_network_Score(&dag,&data,&designmatrix,
priormean,priorsd,priorgamshape,priorgamscale,
maxiters,epsabs,verbose,errverbose,listresults,1,epsabs_inner,maxiters_inner,finitestepsize,
h_lowerend, h_upperend, h_guess, h_epsabs);*/
PROTECT(posterior=NEW_NUMERIC(1));
calc_parameter_marginal(&dag,&data,&designmatrix,
priormean,priorsd,priorgamshape,priorgamscale,
maxiters,epsabs,verbose,errverbose,
denom_modes,childid,paramid,
/*pdfminval, pdfstepsize,*/
epsabs_inner,maxiters_inner,finitestepsize, h_guess, h_epsabs,maxiters_hessian,betafixed, mlik,REAL(posterior),
max_hessian_error,myfactor_brent, maxiters_hessian_brent,num_intervals_brent);
/*gsl_set_error_handler (NULL);*//*Rprintf("Restoring: GSL Error handler\n");*/ /** restore the error handler*/
/** set up memory storage for any network which has each node with <=maxparents **/
/** Roll back into an R MATRIX */
/*for(j=0;j<2;j++){for(i=0;i<numvariates;i++){REAL(VECTOR_ELT(listresults,j))[i]=gsl_matrix_get(posterior,i,j);}} */
#ifdef JUNK
gsl_matrix_free(posterior);
UNPROTECT(1);
return(listresults);
#endif
UNPROTECT(1);
/*Rprintf("posterior=%f\n",REAL(posterior)[0]);*/
return(posterior);
}
