SEXP CHMsuper_validate(SEXP obj) /* placeholder */
{
return ScalarLogical(1);
}
SEXP Cdqrls(SEXP x, SEXP y, SEXP tol, SEXP chk)
{
SEXP ans;
SEXP qr, coefficients, residuals, effects, pivot, qraux;
int n, ny = 0, p, rank, nprotect = 4, pivoted = 0;
double rtol = asReal(tol), *work;
Rboolean check = asLogical(chk);
ans = getDimAttrib(x);
if(check && length(ans) != 2) error(_("'x' is not a matrix"));
int *dims = INTEGER(ans);
n = dims[0]; p = dims[1];
if(n) ny = (int)(XLENGTH(y)/n); /* y : n x ny, or an n - vector */
if(check && n * ny != XLENGTH(y))
error(_("dimensions of 'x' (%d,%d) and 'y' (%d) do not match"),
n,p, XLENGTH(y));
/* These lose attributes, so do after we have extracted dims */
if (TYPEOF(x) != REALSXP) {
PROTECT(x = coerceVector(x, REALSXP));
nprotect++;
}
if (TYPEOF(y) != REALSXP) {
PROTECT(y = coerceVector(y, REALSXP));
nprotect++;
}
double *rptr = REAL(x);
for (R_xlen_t i = 0 ; i < XLENGTH(x) ; i++)
if(!R_FINITE(rptr[i])) error(_("NA/NaN/Inf in '%s'"), "x");
rptr = REAL(y);
for (R_xlen_t i = 0 ; i < XLENGTH(y) ; i++)
if(!R_FINITE(rptr[i])) error(_("NA/NaN/Inf in '%s'"), "y");
const char *ansNms[] = {"qr", "coefficients", "residuals", "effects",
"rank", "pivot", "qraux", "tol", "pivoted", ""};
PROTECT(ans = mkNamed(VECSXP, ansNms));
SET_VECTOR_ELT(ans, 0, qr = duplicate(x));
coefficients = (ny > 1) ? allocMatrix(REALSXP, p, ny) : allocVector(REALSXP, p);
PROTECT(coefficients);
SET_VECTOR_ELT(ans, 1, coefficients);
SET_VECTOR_ELT(ans, 2, residuals = duplicate(y));
SET_VECTOR_ELT(ans, 3, effects = duplicate(y));
PROTECT(pivot = allocVector(INTSXP, p));
int *ip = INTEGER(pivot);
for(int i = 0; i < p; i++) ip[i] = i+1;
SET_VECTOR_ELT(ans, 5, pivot);
PROTECT(qraux = allocVector(REALSXP, p));
SET_VECTOR_ELT(ans, 6, qraux);
SET_VECTOR_ELT(ans, 7, tol);
work = (double *) R_alloc(2 * p, sizeof(double));
F77_CALL(dqrls)(REAL(qr), &n, &p, REAL(y), &ny, &rtol,
REAL(coefficients), REAL(residuals), REAL(effects),
&rank, INTEGER(pivot), REAL(qraux), work);
SET_VECTOR_ELT(ans, 4, ScalarInteger(rank));
for(int i = 0; i < p; i++)
if(ip[i] != i+1) { pivoted = 1; break; }
SET_VECTOR_ELT(ans, 8, ScalarLogical(pivoted));
UNPROTECT(nprotect);
return ans;
}
SEXP pCholesky_validate(SEXP obj)
{
return ScalarLogical(1);
}
SEXP Rscc_check_clustering(const SEXP R_clustering,
const SEXP R_size_constraint,
const SEXP R_type_labels,
const SEXP R_type_constraints,
const SEXP R_primary_data_points)
{
if (!isInteger(R_clustering)) {
iRscc_error("`R_clustering` is not a valid clustering object.");
}
if (!isInteger(getAttrib(R_clustering, install("cluster_count")))) {
iRscc_error("`R_clustering` is not a valid clustering object.");
}
if (!isInteger(R_size_constraint)) {
iRscc_error("`R_size_constraint` must be integer.");
}
if (isNull(R_type_labels)) {
if (!isNull(R_type_constraints)) {
iRscc_error("`R_type_constraints` must be NULL when no types are supplied.");
}
} else {
if (!isInteger(R_type_labels)) {
iRscc_error("`R_type_labels` must be factor, integer or NULL.");
}
if (!isInteger(R_type_constraints)) {
iRscc_error("`R_type_constraints` must be integer.");
}
}
if (!isNull(R_primary_data_points) && !isInteger(R_primary_data_points)) {
iRscc_error("`R_primary_data_points` must be NULL or integer.");
}
const uint64_t num_data_points = (uint64_t) xlength(R_clustering);
const uint64_t num_clusters = (uint64_t) asInteger(getAttrib(R_clustering, install("cluster_count")));
if (num_clusters == 0) {
iRscc_error("`R_clustering` is empty.");
}
scc_ClusterOptions options = scc_get_default_options();
options.size_constraint = (uint32_t) asInteger(R_size_constraint);
if (isInteger(R_type_labels) && isInteger(R_type_constraints)) {
const uint32_t num_types = (uint32_t) xlength(R_type_constraints);
const size_t len_type_labels = (size_t) xlength(R_type_labels);
if (len_type_labels != num_data_points) {
iRscc_error("`R_type_labels` does not match `R_clustering`.");
}
if (num_types >= 2) {
uint32_t* const type_constraints = (uint32_t*) R_alloc(num_types, sizeof(uint32_t)); // Automatically freed by R on return
if (type_constraints == NULL) iRscc_error("Could not allocate memory.");
const int* const tmp_type_constraints = INTEGER(R_type_constraints);
for (size_t i = 0; i < num_types; ++i) {
if (tmp_type_constraints[i] < 0) {
iRscc_error("Negative type size constraint.");
}
type_constraints[i] = (uint32_t) tmp_type_constraints[i];
}
options.num_types = num_types;
options.type_constraints = type_constraints;
options.len_type_labels = len_type_labels;
options.type_labels = INTEGER(R_type_labels);
}
}
if (isInteger(R_primary_data_points)) {
options.len_primary_data_points = (size_t) xlength(R_primary_data_points);
options.primary_data_points = INTEGER(R_primary_data_points);
}
scc_ErrorCode ec;
scc_Clustering* clustering;
if ((ec = scc_init_existing_clustering(num_data_points,
num_clusters,
INTEGER(R_clustering),
false,
&clustering)) != SCC_ER_OK) {
iRscc_scc_error();
}
bool is_OK = false;
if ((ec = scc_check_clustering(clustering,
&options,
&is_OK)) != SCC_ER_OK) {
scc_free_clustering(&clustering);
iRscc_scc_error();
}
scc_free_clustering(&clustering);
return ScalarLogical((int) is_OK);
}
SEXP attribute_hidden do_subset_dflt(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, ax, px, x, subs;
int drop, i, nsubs, type;
/* By default we drop extents of length 1 */
/* Handle cases of extracting a single element from a simple vector
or matrix directly to improve speed for these simple cases. */
SEXP cdrArgs = CDR(args);
SEXP cddrArgs = CDR(cdrArgs);
if (cdrArgs != R_NilValue && cddrArgs == R_NilValue &&
TAG(cdrArgs) == R_NilValue) {
/* one index, not named */
SEXP x = CAR(args);
if (ATTRIB(x) == R_NilValue) {
SEXP s = CAR(cdrArgs);
R_xlen_t i = scalarIndex(s);
switch (TYPEOF(x)) {
case REALSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarReal( REAL(x)[i-1] );
break;
case INTSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarInteger( INTEGER(x)[i-1] );
break;
case LGLSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarLogical( LOGICAL(x)[i-1] );
break;
// do the more rare cases as well, since we've already prepared everything:
case CPLXSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarComplex( COMPLEX(x)[i-1] );
break;
case RAWSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarRaw( RAW(x)[i-1] );
break;
default: break;
}
}
}
else if (cddrArgs != R_NilValue && CDR(cddrArgs) == R_NilValue &&
TAG(cdrArgs) == R_NilValue && TAG(cddrArgs) == R_NilValue) {
/* two indices, not named */
SEXP x = CAR(args);
SEXP attr = ATTRIB(x);
if (TAG(attr) == R_DimSymbol && CDR(attr) == R_NilValue) {
/* only attribute of x is 'dim' */
SEXP dim = CAR(attr);
if (TYPEOF(dim) == INTSXP && LENGTH(dim) == 2) {
/* x is a matrix */
SEXP si = CAR(cdrArgs);
SEXP sj = CAR(cddrArgs);
R_xlen_t i = scalarIndex(si);
R_xlen_t j = scalarIndex(sj);
int nrow = INTEGER(dim)[0];
int ncol = INTEGER(dim)[1];
if (i > 0 && j > 0 && i <= nrow && j <= ncol) {
/* indices are legal scalars */
R_xlen_t k = i - 1 + nrow * (j - 1);
switch (TYPEOF(x)) {
case REALSXP:
if (k < LENGTH(x))
return ScalarReal( REAL(x)[k] );
break;
case INTSXP:
if (k < LENGTH(x))
return ScalarInteger( INTEGER(x)[k] );
break;
case LGLSXP:
if (k < LENGTH(x))
return ScalarLogical( LOGICAL(x)[k] );
break;
case CPLXSXP:
if (k < LENGTH(x))
return ScalarComplex( COMPLEX(x)[k] );
break;
case RAWSXP:
if (k < LENGTH(x))
return ScalarRaw( RAW(x)[k] );
break;
default: break;
}
}
}
}
}
PROTECT(args);
drop = 1;
ExtractDropArg(args, &drop);
x = CAR(args);
/* This was intended for compatibility with S, */
/* but in fact S does not do this. */
/* FIXME: replace the test by isNull ... ? */
if (x == R_NilValue) {
UNPROTECT(1);
return x;
}
subs = CDR(args);
nsubs = length(subs); /* Will be short */
type = TYPEOF(x);
/* Here coerce pair-based objects into generic vectors. */
/* All subsetting takes place on the generic vector form. */
ax = x;
if (isVector(x))
PROTECT(ax);
else if (isPairList(x)) {
SEXP dim = getAttrib(x, R_DimSymbol);
int ndim = length(dim);
if (ndim > 1) {
PROTECT(ax = allocArray(VECSXP, dim));
setAttrib(ax, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol));
setAttrib(ax, R_NamesSymbol, getAttrib(x, R_DimNamesSymbol));
}
else {
PROTECT(ax = allocVector(VECSXP, length(x)));
setAttrib(ax, R_NamesSymbol, getAttrib(x, R_NamesSymbol));
}
for(px = x, i = 0 ; px != R_NilValue ; px = CDR(px))
SET_VECTOR_ELT(ax, i++, CAR(px));
}
else errorcall(call, R_MSG_ob_nonsub, type2char(TYPEOF(x)));
/* This is the actual subsetting code. */
/* The separation of arrays and matrices is purely an optimization. */
if(nsubs < 2) {
SEXP dim = getAttrib(x, R_DimSymbol);
int ndim = length(dim);
PROTECT(ans = VectorSubset(ax, (nsubs == 1 ? CAR(subs) : R_MissingArg),
call));
/* one-dimensional arrays went through here, and they should
have their dimensions dropped only if the result has
length one and drop == TRUE
*/
if(ndim == 1) {
SEXP attr, attrib, nattrib;
int len = length(ans);
if(!drop || len > 1) {
// must grab these before the dim is set.
SEXP nm = PROTECT(getAttrib(ans, R_NamesSymbol));
PROTECT(attr = allocVector(INTSXP, 1));
INTEGER(attr)[0] = length(ans);
setAttrib(ans, R_DimSymbol, attr);
if((attrib = getAttrib(x, R_DimNamesSymbol)) != R_NilValue) {
/* reinstate dimnames, include names of dimnames */
PROTECT(nattrib = duplicate(attrib));
SET_VECTOR_ELT(nattrib, 0, nm);
setAttrib(ans, R_DimNamesSymbol, nattrib);
setAttrib(ans, R_NamesSymbol, R_NilValue);
UNPROTECT(1);
}
UNPROTECT(2);
}
}
} else {
if (nsubs != length(getAttrib(x, R_DimSymbol)))
errorcall(call, _("incorrect number of dimensions"));
if (nsubs == 2)
ans = MatrixSubset(ax, subs, call, drop);
else
ans = ArraySubset(ax, subs, call, drop);
PROTECT(ans);
}
/* Note: we do not coerce back to pair-based lists. */
/* They are "defunct" in this version of R. */
if (type == LANGSXP) {
ax = ans;
PROTECT(ans = allocList(LENGTH(ax)));
if ( LENGTH(ax) > 0 )
SET_TYPEOF(ans, LANGSXP);
for(px = ans, i = 0 ; px != R_NilValue ; px = CDR(px))
SETCAR(px, VECTOR_ELT(ax, i++));
setAttrib(ans, R_DimSymbol, getAttrib(ax, R_DimSymbol));
setAttrib(ans, R_DimNamesSymbol, getAttrib(ax, R_DimNamesSymbol));
setAttrib(ans, R_NamesSymbol, getAttrib(ax, R_NamesSymbol));
SET_NAMED(ans, NAMED(ax)); /* PR#7924 */
}
else {
PROTECT(ans);
}
if (ATTRIB(ans) != R_NilValue) { /* remove probably erroneous attr's */
setAttrib(ans, R_TspSymbol, R_NilValue);
#ifdef _S4_subsettable
if(!IS_S4_OBJECT(x))
#endif
setAttrib(ans, R_ClassSymbol, R_NilValue);
}
UNPROTECT(4);
return ans;
}
SEXP R_valid_sgCMatrix(SEXP x) {
if (!inherits(x, "sgCMatrix"))
error("'x' not of class sgCMatrix");
int i, k, f, l;
SEXP px, ix, dx;
px = getAttrib(x, install("p"));
ix = getAttrib(x, install("i"));
dx = getAttrib(x, install("Dim"));
if (isNull(px) || isNull(ix) || isNull(dx))
return mkString("slot p, i, or Dim is NULL");
if (TYPEOF(px) != INTSXP || TYPEOF(ix) != INTSXP || TYPEOF(dx) != INTSXP)
return mkString("slot p, i, or Dim not of storage type integer");
if (LENGTH(dx) != 2 || INTEGER(dx)[0] < 0 || INTEGER(dx)[1] < 0)
return mkString("slot Dim invalid");
if (INTEGER(dx)[1] != LENGTH(px)-1)
return mkString("slot p and Dim do not conform");
f = l = INTEGER(px)[0];
if (f != 0)
return mkString("slot p invalid");
for (i = 1; i < LENGTH(px); i++) {
l = INTEGER(px)[i];
if (l < f)
return mkString("slot p invalid");
f = l;
}
if (l != LENGTH(ix))
return mkString("slot p and i do not conform");
if (l > 0) {
f = l = INTEGER(ix)[0];
for (i = 1; i < LENGTH(ix); i++) {
k = INTEGER(ix)[i];
if (k < f)
f = k;
else
if (k > l)
l = k;
}
if (f < 0 || l > INTEGER(dx)[0]-1)
return mkString("slot i invalid");
}
ix = getAttrib(x, install("Dimnames"));
if (LENGTH(ix) != 2 || TYPEOF(ix) != VECSXP)
return mkString("slot Dimnames invalid");
px = VECTOR_ELT(ix, 0);
if (!isNull(px)) {
if (TYPEOF(px) != STRSXP)
return mkString("slot Dimnames invalid");
if (LENGTH(px) != INTEGER(dx)[0])
return mkString("slot Dim and Dimnames do not conform");
}
px = VECTOR_ELT(ix, 1);
if (!isNull(px)) {
if (TYPEOF(px) != STRSXP)
return mkString("slot Dimnames invalid");
if (LENGTH(px) != INTEGER(dx)[1])
return mkString("slot Dim and Dimnames do not conform");
}
return ScalarLogical(TRUE);
}
SEXP R_ring_buffer_empty(SEXP extPtr) {
return ScalarLogical(ring_buffer_empty(ring_buffer_get(extPtr, 1)));
}
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;
}
/* backend for the all.equal() function for bn objects. */
SEXP all_equal(SEXP target, SEXP current) {
int nnodes = 0, narcs = 0;
int *t = NULL, *c = NULL;
SEXP tnodes, cnodes, cmatch, tarcs, carcs, thash, chash;
/* get the node set of each network. */
tnodes = getAttrib(getListElement(target, "nodes"), R_NamesSymbol);
cnodes = getAttrib(getListElement(current, "nodes"), R_NamesSymbol);
/* first check: node sets must have the same size. */
if (length(tnodes) != length(cnodes))
return mkString("Different number of nodes");
/* store for future use. */
nnodes = length(tnodes);
/* second check: node sets must contain the same node labels. */
PROTECT(cmatch = match(tnodes, cnodes, 0));
c = INTEGER(cmatch);
/* sorting takes care of different node orderings. */
R_isort(c, nnodes);
/* check that every node in the first network is also present in the
* second one; this is enough because the node sets have the same size
* and the nodes in each set are guaranteed to be unique. */
for (int i = 0; i < nnodes; i++) {
if (c[i] != i + 1) {
UNPROTECT(1);
return mkString("Different node sets");
}/*THEN*/
}/*FOR*/
UNPROTECT(1);
/* get the node set of each network. */
tarcs = getListElement(target, "arcs");
carcs = getListElement(current, "arcs");
/* third check: arc sets must have the same size. */
if (length(tarcs) != length(carcs))
return mkString("Different number of directed/undirected arcs");
/* store for future use. */
narcs = length(tarcs)/2;
/* fourth check: arcs sets must contain the same arcs. */
if (narcs > 0) {
/* compute the numeric hashes of both arc sets (against the same
* node set to make comparisons meaningful) and sort them. */
PROTECT(thash = arc_hash(tarcs, tnodes, FALSE, TRUE));
PROTECT(chash = arc_hash(carcs, tnodes, FALSE, TRUE));
/* dereference the resulting integer vectors. */
t = INTEGER(thash);
c = INTEGER(chash);
/* sorting takes care of different arc orderings. */
R_isort(t, narcs);
R_isort(c, narcs);
/* compare the integer vectors as generic memory areas. */
if (memcmp(t, c, narcs * sizeof(int))) {
UNPROTECT(2);
return mkString("Different arc sets");
}/*THEN*/
UNPROTECT(2);
}/*THEN*/
/* all checks completed successfully, returning TRUE. */
return ScalarLogical(TRUE);
}/*ALL_EQUAL*/
SEXP R_hasSlot(SEXP obj, SEXP name)
{
return ScalarLogical(R_has_slot(obj, name));
}
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;
}
/* a single step of the optimized hill climbing (one arc addition/removal/reversal). */
SEXP hc_opt_step(SEXP amat, SEXP nodes, SEXP added, SEXP cache, SEXP reference,
SEXP wlmat, SEXP blmat, SEXP nparents, SEXP maxp, SEXP debug) {
int nnodes = length(nodes), i = 0, j = 0;
int *am = NULL, *ad = NULL, *w = NULL, *b = NULL, debuglevel = isTRUE(debug);
int counter = 0, update = 1, from = 0, to = 0, *path = NULL, *scratch = NULL;
double *cache_value = NULL, temp = 0, max = 0, tol = MACHINE_TOL;
double *mp = REAL(maxp), *np = REAL(nparents);
SEXP bestop;
/* allocate and initialize the return value (use FALSE as a canary value). */
PROTECT(bestop = allocVector(VECSXP, 3));
setAttrib(bestop, R_NamesSymbol, mkStringVec(3, "op", "from", "to"));
/* allocate and initialize a dummy FALSE object. */
SET_VECTOR_ELT(bestop, 0, ScalarLogical(FALSE));
/* allocate buffers for c_has_path(). */
path = Calloc1D(nnodes, sizeof(int));
scratch = Calloc1D(nnodes, sizeof(int));
/* save pointers to the numeric/integer matrices. */
cache_value = REAL(cache);
ad = INTEGER(added);
am = INTEGER(amat);
w = INTEGER(wlmat);
b = INTEGER(blmat);
if (debuglevel > 0) {
/* count how may arcs are to be tested. */
for (i = 0; i < nnodes * nnodes; i++)
counter += ad[i];
Rprintf("----------------------------------------------------------------\n");
Rprintf("* trying to add one of %d arcs.\n", counter);
}/*THEN*/
for (i = 0; i < nnodes; i++) {
for (j = 0; j < nnodes; j++) {
/* nothing to see, move along. */
if (ad[CMC(i, j, nnodes)] == 0)
continue;
/* retrieve the score delta from the cache. */
temp = cache_value[CMC(i, j, nnodes)];
if (debuglevel > 0) {
Rprintf(" > trying to add %s -> %s.\n", NODE(i), NODE(j));
Rprintf(" > delta between scores for nodes %s %s is %lf.\n",
NODE(i), NODE(j), temp);
}/*THEN*/
/* this score delta is the best one at the moment, so add the arc if it
* does not introduce cycles in the graph. */
if (temp - max > tol) {
if (c_has_path(j, i, am, nnodes, nodes, FALSE, FALSE, path, scratch,
FALSE)) {
if (debuglevel > 0)
Rprintf(" > not adding, introduces cycles in the graph.\n");
continue;
}/*THEN*/
if (debuglevel > 0)
Rprintf(" @ adding %s -> %s.\n", NODE(i), NODE(j));
/* update the return value. */
bestop_update(bestop, "set", NODE(i), NODE(j));
/* store the node indices to update the reference scores. */
from = i;
to = j;
/* update the threshold score delta. */
max = temp;
}/*THEN*/
}/*FOR*/
}/*FOR*/
if (debuglevel > 0) {
/* count how may arcs are to be tested. */
for (i = 0, counter = 0; i < nnodes * nnodes; i++)
counter += am[i] * (1 - w[i]);
Rprintf("----------------------------------------------------------------\n");
Rprintf("* trying to remove one of %d arcs.\n", counter);
}/*THEN*/
for (i = 0; i < nnodes; i++) {
for (j = 0; j < nnodes; j++) {
/* nothing to see, move along. */
if (am[CMC(i, j, nnodes)] == 0)
continue;
/* whitelisted arcs are not to be removed, ever. */
if (w[CMC(i, j, nnodes)] == 1)
continue;
/* retrieve the score delta from the cache. */
temp = cache_value[CMC(i, j, nnodes)];
if (debuglevel > 0) {
Rprintf(" > trying to remove %s -> %s.\n", NODE(i), NODE(j));
Rprintf(" > delta between scores for nodes %s %s is %lf.\n",
NODE(i), NODE(j), temp);
}/*THEN*/
if (temp - max > tol) {
if (debuglevel > 0)
Rprintf(" @ removing %s -> %s.\n", NODE(i), NODE(j));
/* update the return value. */
bestop_update(bestop, "drop", NODE(i), NODE(j));
/* store the node indices to update the reference scores. */
from = i;
to = j;
/* update the threshold score delta. */
max = temp;
}/*THEN*/
}/*FOR*/
}/*FOR*/
if (debuglevel > 0) {
/* count how may arcs are to be tested. */
for (i = 0, counter = 0; i < nnodes; i++)
for (j = 0; j < nnodes; j++)
counter += am[CMC(i, j, nnodes)] * (1 - b[CMC(j, i, nnodes)]);
Rprintf("----------------------------------------------------------------\n");
Rprintf("* trying to reverse one of %d arcs.\n", counter);
}/*THEN*/
for (i = 0; i < nnodes; i++) {
for (j = 0; j < nnodes; j++) {
/* nothing to see, move along. */
if (am[CMC(i, j, nnodes)] == 0)
continue;
/* don't reverse an arc if the one in the opposite direction is
* blacklisted, ever. */
if (b[CMC(j, i, nnodes)] == 1)
continue;
/* do not reverse an arc if that means violating the limit on the
* maximum number of parents. */
if (np[i] >= *mp)
continue;
/* retrieve the score delta from the cache. */
temp = cache_value[CMC(i, j, nnodes)] + cache_value[CMC(j, i, nnodes)];
/* nuke small values and negative zeroes. */
if (fabs(temp) < tol) temp = 0;
if (debuglevel > 0) {
Rprintf(" > trying to reverse %s -> %s.\n", NODE(i), NODE(j));
Rprintf(" > delta between scores for nodes %s %s is %lf.\n",
NODE(i), NODE(j), temp);
}/*THEN*/
if (temp - max > tol) {
if (c_has_path(i, j, am, nnodes, nodes, FALSE, TRUE, path, scratch,
FALSE)) {
if (debuglevel > 0)
Rprintf(" > not reversing, introduces cycles in the graph.\n");
continue;
}/*THEN*/
if (debuglevel > 0)
Rprintf(" @ reversing %s -> %s.\n", NODE(i), NODE(j));
/* update the return value. */
bestop_update(bestop, "reverse", NODE(i), NODE(j));
/* store the node indices to update the reference scores. */
from = i;
to = j;
/* both nodes' reference scores must be updated. */
update = 2;
/* update the threshold score delta. */
max = temp;
}/*THEN*/
}/*FOR*/
}/*FOR*/
/* update the reference scores. */
REAL(reference)[to] += cache_value[CMC(from, to, nnodes)];
if (update == 2)
REAL(reference)[from] += cache_value[CMC(to, from, nnodes)];
Free1D(path);
Free1D(scratch);
UNPROTECT(1);
return bestop;
}/*HC_OPT_STEP*/
/* This is a primitive (with no arguments) */
SEXP attribute_hidden do_interactive(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
return ScalarLogical( (R_Interactive) ? 1 : 0 );
}
SEXP R_initMethodDispatch(SEXP envir)
{
if(envir && !isNull(envir))
Methods_Namespace = envir;
if(!Methods_Namespace)
Methods_Namespace = R_GlobalEnv;
if(initialized)
return(envir);
s_dot_Methods = install(".Methods");
s_skeleton = install("skeleton");
s_expression = install("expression");
s_function = install("function");
s_getAllMethods = install("getAllMethods");
s_objectsEnv = install("objectsEnv");
s_MethodsListSelect = install("MethodsListSelect");
s_sys_dot_frame = install("sys.frame");
s_sys_dot_call = install("sys.call");
s_sys_dot_function = install("sys.function");
s_generic = install("generic");
s_generic_dot_skeleton = install("generic.skeleton");
s_subset_gets = install("[<-");
s_element_gets = install("[[<-");
s_argument = install("argument");
s_allMethods = install("allMethods");
R_FALSE = ScalarLogical(FALSE);
R_PreserveObject(R_FALSE);
R_TRUE = ScalarLogical(TRUE);
R_PreserveObject(R_TRUE);
/* some strings (NOT symbols) */
s_missing = mkString("missing");
setAttrib(s_missing, R_PackageSymbol, mkString("methods"));
R_PreserveObject(s_missing);
s_base = mkString("base");
R_PreserveObject(s_base);
/* Initialize method dispatch, using the static */
R_set_standardGeneric_ptr(
(table_dispatch_on ? R_dispatchGeneric : R_standardGeneric)
, Methods_Namespace);
R_set_quick_method_check(
(table_dispatch_on ? R_quick_dispatch : R_quick_method_check));
/* Some special lists of primitive skeleton calls.
These will be promises under lazy-loading.
*/
PROTECT(R_short_skeletons =
findVar(install(".ShortPrimitiveSkeletons"),
Methods_Namespace));
if(TYPEOF(R_short_skeletons) == PROMSXP)
R_short_skeletons = eval(R_short_skeletons, Methods_Namespace);
R_PreserveObject(R_short_skeletons);
UNPROTECT(1);
PROTECT(R_empty_skeletons =
findVar(install(".EmptyPrimitiveSkeletons"),
Methods_Namespace));
if(TYPEOF(R_empty_skeletons) == PROMSXP)
R_empty_skeletons = eval(R_empty_skeletons, Methods_Namespace);
R_PreserveObject(R_empty_skeletons);
UNPROTECT(1);
if(R_short_skeletons == R_UnboundValue ||
R_empty_skeletons == R_UnboundValue)
error(_("could not find the skeleton calls for 'methods' (package detached?): expect very bad things to happen"));
f_x_i_skeleton = VECTOR_ELT(R_short_skeletons, 0);
fgets_x_i_skeleton = VECTOR_ELT(R_short_skeletons, 1);
f_x_skeleton = VECTOR_ELT(R_empty_skeletons, 0);
fgets_x_skeleton = VECTOR_ELT(R_empty_skeletons, 1);
init_loadMethod();
initialized = 1;
return(envir);
}
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 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;
}
static SEXP baseCallback(GEevent task, pGEDevDesc dd, SEXP data)
{
GESystemDesc *sd;
baseSystemState *bss, *bss2;
SEXP result = R_NilValue;
switch (task) {
case GE_FinaliseState:
/* called from unregisterOne */
sd = dd->gesd[baseRegisterIndex];
free(sd->systemSpecific);
sd->systemSpecific = NULL;
break;
case GE_InitState:
{
/* called from registerOne */
pDevDesc dev;
GPar *ddp;
sd = dd->gesd[baseRegisterIndex];
dev = dd->dev;
bss = sd->systemSpecific = malloc(sizeof(baseSystemState));
/* Bail out if necessary */
if (!bss) return result;
/* Make sure initialized, or valgrind may complain. */
memset(bss, 0, sizeof(baseSystemState));
ddp = &(bss->dp);
GInit(ddp);
/* For some things, the device sets the starting value at least. */
ddp->ps = dev->startps;
ddp->col = ddp->fg = dev->startcol;
ddp->bg = dev->startfill;
ddp->font = dev->startfont;
ddp->lty = dev->startlty;
ddp->gamma = dev->startgamma;
/* Initialise the gp settings too: formerly in addDevice. */
copyGPar(ddp, &(bss->gp));
GReset(dd);
/*
* The device has not yet received any base output
*/
bss->baseDevice = FALSE;
/* Indicate success */
result = R_BlankString;
break;
}
case GE_CopyState:
{
/* called from GEcopyDisplayList */
pGEDevDesc curdd = GEcurrentDevice();
bss = dd->gesd[baseRegisterIndex]->systemSpecific;
bss2 = curdd->gesd[baseRegisterIndex]->systemSpecific;
copyGPar(&(bss->dpSaved), &(bss2->dpSaved));
restoredpSaved(curdd);
copyGPar(&(bss2->dp), &(bss2->gp));
GReset(curdd);
break;
}
case GE_SaveState:
/* called from GEinitDisplayList */
bss = dd->gesd[baseRegisterIndex]->systemSpecific;
copyGPar(&(bss->dp), &(bss->dpSaved));
break;
case GE_RestoreState:
/* called from GEplayDisplayList */
bss = dd->gesd[baseRegisterIndex]->systemSpecific;
restoredpSaved(dd);
copyGPar(&(bss->dp), &(bss->gp));
GReset(dd);
break;
case GE_SaveSnapshotState:
/* called from GEcreateSnapshot */
bss = dd->gesd[baseRegisterIndex]->systemSpecific;
/* Changed from INTSXP in 2.7.0: but saved graphics lists
are protected by an R version number */
PROTECT(result = allocVector(RAWSXP, sizeof(GPar)));
copyGPar(&(bss->dpSaved), (GPar*) RAW(result));
UNPROTECT(1);
break;
case GE_RestoreSnapshotState:
/* called from GEplaySnapshot */
bss = dd->gesd[baseRegisterIndex]->systemSpecific;
copyGPar((GPar*) RAW(data), &(bss->dpSaved));
restoredpSaved(dd);
copyGPar(&(bss->dp), &(bss->gp));
GReset(dd);
break;
case GE_CheckPlot:
/* called from GEcheckState:
Check that the current plotting state is "valid"
*/
bss = dd->gesd[baseRegisterIndex]->systemSpecific;
result = ScalarLogical(bss->baseDevice ?
(bss->gp.state == 1) && bss->gp.valid :
TRUE);
break;
case GE_ScalePS:
{
/* called from GEhandleEvent in devWindows.c */
GPar *ddp, *ddpSaved;
bss = dd->gesd[baseRegisterIndex]->systemSpecific;
ddp = &(bss->dp);
ddpSaved = &(bss->dpSaved);
if (isReal(data) && LENGTH(data) == 1) {
double rf = REAL(data)[0];
ddp->scale *= rf;
/* Modify the saved settings so this effects display list too */
ddpSaved->scale *= rf;
} else
error("event 'GE_ScalePS' requires a single numeric value");
break;
}
}
return result;
}
SEXP mc_rm_child(SEXP sPid)
{
int pid = asInteger(sPid);
return ScalarLogical(rm_child_(pid));
}
SEXP Riproc_recv_model(SEXP ytime, SEXP ysender, SEXP yreceiver,
SEXP xtime, SEXP xsender, SEXP xreceiver,
SEXP factors, SEXP variables, SEXP nsend, SEXP nrecv,
SEXP loops)
{
struct properties p;
struct history hx, hy;
struct design s, r;
struct design2 d;
struct terms_object tm;
const struct message *msgs;
size_t nmsg;
size_t iter, dim, nc, ntot, rank;
size_t ncextra;
struct recv_fit fit;
const struct recv_loglik *ll;
const struct recv_model *model;
const struct constr *constr;
const double *beta, *nu;
double dev;
SEXP names;
SEXP ret = NULL_USER_OBJECT;
int k;
int err = 0;
err = get_properties(nsend, nrecv, loops, &p);
if (err < 0)
goto properties_fail;
history_init(&hy, p.nsend, p.nrecv);
err = get_history(ytime, ysender, yreceiver, &hy);
if (err < 0)
goto yhistory_fail;
history_init(&hx, p.nsend, p.nrecv);
err = get_history(xtime, xsender, xreceiver, &hx);
if (err < 0)
goto xhistory_fail;
design_init(&s, &hx, p.nsend);
design_init(&r, &hx, p.nrecv);
design2_init(&d, &hx, p.nsend, p.nrecv);
err = get_terms_object(factors, variables, &s, &r, &d, &tm);
if (err < 0)
goto terms_fail;
history_get_messages(&hy, &msgs, &nmsg);
recv_fit_init(&fit, &r, &d, p.exclude_loops, msgs, nmsg, NULL, NULL);
ncextra = recv_fit_extra_constr_count(&fit);
if (ncextra)
warning("adding %zd %s to make parameters identifiable\n",
ncextra, ncextra == 1 ? "constraint" : "constraints");
err = do_fit(&fit, NULL, NULL, &iter);
if (err < 0)
goto fit_fail;
constr = recv_fit_constr(&fit);
nc = constr_count(constr);
ll = recv_fit_loglik(&fit);
ntot = recv_loglik_count(ll);
model = recv_loglik_model(ll);
beta = (recv_model_params(model))->recv.traits; /* HACK */
nu = recv_fit_duals(&fit);
dim = recv_model_dim(model);
rank = dim - nc;
dev = recv_loglik_dev(ll);
PROTECT(ret = NEW_LIST(16));
PROTECT(names = NEW_CHARACTER(16));
SET_NAMES(ret, names);
k = 0;
SET_STRING_ELT(names, k, COPY_TO_USER_STRING("coefficients"));
SET_VECTOR_ELT(ret, k, alloc_vector_copy(beta, dim));
k++;
SET_STRING_ELT(names, k, COPY_TO_USER_STRING("duals"));
SET_VECTOR_ELT(ret, k, alloc_vector_copy(nu, nc));
k++;
SET_STRING_ELT(names, k, COPY_TO_USER_STRING("constraints"));
SET_VECTOR_ELT(ret, k, alloc_matrix_copy(constr_all_wts(constr), nc, dim));
k++;
SET_STRING_ELT(names, k, COPY_TO_USER_STRING("constraint.values"));
SET_VECTOR_ELT(ret, k, alloc_vector_copy(constr_all_vals(constr), nc));
k++;
SET_STRING_ELT(names, k, COPY_TO_USER_STRING("rank"));
SET_VECTOR_ELT(ret, k, ScalarInteger((int)rank));
k++;
SET_STRING_ELT(names, k, COPY_TO_USER_STRING("deviance"));
SET_VECTOR_ELT(ret, k, ScalarReal(dev));
k++;
SET_STRING_ELT(names, k, COPY_TO_USER_STRING("aic"));
SET_VECTOR_ELT(ret, k, ScalarReal(dev + (double) 2 * rank));
k++;
SET_STRING_ELT(names, k, COPY_TO_USER_STRING("null.deviance"));
SET_VECTOR_ELT(ret, k, ScalarReal(recv_fit_dev0(&fit)));
k++;
SET_STRING_ELT(names, k, COPY_TO_USER_STRING("iter"));
SET_VECTOR_ELT(ret, k, ScalarInteger((int)iter));
k++;
SET_STRING_ELT(names, k, COPY_TO_USER_STRING("df.residual"));
SET_VECTOR_ELT(ret, k, ScalarReal((double)(ntot - rank)));
k++;
SET_STRING_ELT(names, k, COPY_TO_USER_STRING("df.null"));
SET_VECTOR_ELT(ret, k, ScalarReal((double)ntot));
k++;
SET_STRING_ELT(names, k, COPY_TO_USER_STRING("converged"));
SET_VECTOR_ELT(ret, k, ScalarLogical(TRUE));
k++;
SET_STRING_ELT(names, k, COPY_TO_USER_STRING("names"));
SET_VECTOR_ELT(ret, k, alloc_term_labels(&tm.terms));
k++;
SET_STRING_ELT(names, k, COPY_TO_USER_STRING("perm"));
SET_VECTOR_ELT(ret, k, alloc_terms_permute(&tm.terms, &r, &d));
k++;
SET_STRING_ELT(names, k, COPY_TO_USER_STRING("score"));
SET_VECTOR_ELT(ret, k, alloc_score(ll));
k++;
SET_STRING_ELT(names, k, COPY_TO_USER_STRING("imat"));
SET_VECTOR_ELT(ret, k, alloc_imat(&fit));
k++;
UNPROTECT(2);
fit_fail:
recv_fit_deinit(&fit);
terms_fail:
design2_deinit(&d);
design_deinit(&r);
design_deinit(&s);
xhistory_fail:
history_deinit(&hx);
yhistory_fail:
history_deinit(&hy);
properties_fail:
return ret;
}
SEXP mc_is_child()
{
return ScalarLogical(is_master ? FALSE : TRUE);
}
SEXP gribr_is_null_ptr (SEXP gribr_ptr) {
return ScalarLogical(!R_ExternalPtrAddr(gribr_ptr));
}
/* NA = query, TRUE/FALSE = set R_Interactive accordingly */
SEXP mc_interactive(SEXP sWhat) {
int what = asInteger(sWhat);
if (what != NA_INTEGER)
R_Interactive = what;
return ScalarLogical(R_Interactive);
}
SEXP devdisplaylist(SEXP args)
{
pGEDevDesc gdd = GEcurrentDevice();
return ScalarLogical(gdd->displayListOn);
}
static SEXP Julia_R_Scalar(jl_value_t *Var)
{
SEXP ans = R_NilValue;
double tmpfloat;
//most common type is here
if (jl_is_int32(Var))
{
PROTECT(ans = ScalarInteger(jl_unbox_int32(Var)));
UNPROTECT(1);
}
else if (jl_is_int64(Var))
{
tmpfloat=(double)jl_unbox_int64(Var);
if (inInt32Range(tmpfloat))
PROTECT(ans = ScalarInteger((int32_t)jl_unbox_int64(Var)));
else
PROTECT(ans = ScalarReal(tmpfloat));
UNPROTECT(1);
}
//more integer type
if (jl_is_uint32(Var))
{
tmpfloat=(double)jl_unbox_uint32(Var);
if (inInt32Range(tmpfloat))
PROTECT(ans = ScalarInteger((int32_t)jl_unbox_uint32(Var)));
else
PROTECT(ans = ScalarReal(tmpfloat));
UNPROTECT(1);
}
else if (jl_is_uint64(Var))
{
tmpfloat=(double)jl_unbox_int64(Var);
if (inInt32Range(tmpfloat))
PROTECT(ans = ScalarInteger((int32_t)jl_unbox_uint64(Var)));
else
PROTECT(ans = ScalarReal(tmpfloat));
UNPROTECT(1);
}
else if (jl_is_float64(Var))
{
PROTECT(ans = ScalarReal(jl_unbox_float64(Var)));
UNPROTECT(1);
}
else if (jl_is_float32(Var))
{
PROTECT(ans = ScalarReal(jl_unbox_float32(Var)));
UNPROTECT(1);
}
else if (jl_is_bool(Var))
{
PROTECT(ans = ScalarLogical(jl_unbox_bool(Var)));
UNPROTECT(1);
}
else if (jl_is_int8(Var))
{
PROTECT(ans = ScalarInteger(jl_unbox_int8(Var)));
UNPROTECT(1);
}
else if (jl_is_uint8(Var))
{
PROTECT(ans = ScalarInteger(jl_unbox_uint8(Var)));
UNPROTECT(1);
}
else if (jl_is_int16(Var))
{
PROTECT(ans = ScalarInteger(jl_unbox_int16(Var)));
UNPROTECT(1);
}
else if (jl_is_uint16(Var))
{
PROTECT(ans = ScalarInteger(jl_unbox_uint16(Var)));
UNPROTECT(1);
}
else if (jl_is_utf8_string(Var))
{
PROTECT(ans = allocVector(STRSXP, 1));
SET_STRING_ELT(ans, 0, mkCharCE(jl_string_data(Var), CE_UTF8));
UNPROTECT(1);
}
else if (jl_is_ascii_string(Var))
{
PROTECT(ans = ScalarString(mkChar(jl_string_data(Var))));
UNPROTECT(1);
}
return ans;
}
SEXP do_visibleflag(SEXP call, SEXP op, SEXP args, SEXP rho)
{
return ScalarLogical(R_Visible);
}
SEXP attribute_hidden c_is_integerish(SEXP x, SEXP tolerance) {
return ScalarLogical(isIntegerish(x, REAL_RO(tolerance)[0], FALSE));
}
SEXP pBunchKaufman_validate(SEXP obj)
{
return ScalarLogical(1);
}
SEXP pollSocket(SEXP sockets_, SEXP events_, SEXP timeout_) {
SEXP result;
if(TYPEOF(timeout_) != INTSXP) {
error("poll timeout must be an integer.");
}
if(TYPEOF(sockets_) != VECSXP || LENGTH(sockets_) == 0) {
error("A non-empy list of sockets is required as first argument.");
}
int nsock = LENGTH(sockets_);
PROTECT(result = allocVector(VECSXP, nsock));
if (TYPEOF(events_) != VECSXP) {
error("event list must be a list of strings or a list of vectors of strings.");
}
if(LENGTH(events_) != nsock) {
error("event list must be the same length as socket list.");
}
zmq_pollitem_t *pitems = (zmq_pollitem_t*)R_alloc(nsock, sizeof(zmq_pollitem_t));
if (pitems == NULL) {
error("failed to allocate memory for zmq_pollitem_t array.");
}
try {
for (int i = 0; i < nsock; i++) {
zmq::socket_t* socket = reinterpret_cast<zmq::socket_t*>(checkExternalPointer(VECTOR_ELT(sockets_, i), "zmq::socket_t*"));
pitems[i].socket = (void*)*socket;
pitems[i].events = rzmq_build_event_bitmask(VECTOR_ELT(events_, i));
}
int rc = zmq::poll(pitems, nsock, *INTEGER(timeout_));
if(rc >= 0) {
for (int i = 0; i < nsock; i++) {
SEXP events, names;
// Pre count number of polled events so we can
// allocate appropriately sized lists.
short eventcount = 0;
if (pitems[i].events & ZMQ_POLLIN) eventcount++;
if (pitems[i].events & ZMQ_POLLOUT) eventcount++;
if (pitems[i].events & ZMQ_POLLERR) eventcount++;
PROTECT(events = allocVector(VECSXP, eventcount));
PROTECT(names = allocVector(VECSXP, eventcount));
eventcount = 0;
if (pitems[i].events & ZMQ_POLLIN) {
SET_VECTOR_ELT(events, eventcount, ScalarLogical(pitems[i].revents & ZMQ_POLLIN));
SET_VECTOR_ELT(names, eventcount, mkChar("read"));
eventcount++;
}
if (pitems[i].events & ZMQ_POLLOUT) {
SET_VECTOR_ELT(names, eventcount, mkChar("write"));
SET_VECTOR_ELT(events, eventcount, ScalarLogical(pitems[i].revents & ZMQ_POLLOUT));
eventcount++;
}
if (pitems[i].events & ZMQ_POLLERR) {
SET_VECTOR_ELT(names, eventcount, mkChar("error"));
SET_VECTOR_ELT(events, eventcount, ScalarLogical(pitems[i].revents & ZMQ_POLLERR));
}
setAttrib(events, R_NamesSymbol, names);
SET_VECTOR_ELT(result, i, events);
}
} else {
error("polling zmq sockets failed.");
}
} catch(std::exception& e) {
error(e.what());
}
// Release the result list (1), and per socket
// events lists with associated names (2*nsock).
UNPROTECT(1 + 2*nsock);
return result;
}
SEXP SVD_validate(SEXP obj)
{
return ScalarLogical(1);
}
/* browser(text = "", condition = NULL, expr = TRUE, skipCalls = 0L)
* ------- but also called from ./eval.c */
SEXP attribute_hidden do_browser(SEXP call, SEXP op, SEXP args, SEXP rho)
{
RCNTXT *saveToplevelContext;
RCNTXT *saveGlobalContext;
RCNTXT thiscontext, returncontext, *cptr;
int savestack, browselevel;
SEXP ap, topExp, argList;
/* argument matching */
PROTECT(ap = list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue));
SET_TAG(ap, install("text"));
SET_TAG(CDR(ap), install("condition"));
SET_TAG(CDDR(ap), install("expr"));
SET_TAG(CDDDR(ap), install("skipCalls"));
argList = matchArgs(ap, args, call);
UNPROTECT(1);
PROTECT(argList);
/* substitute defaults */
if(CAR(argList) == R_MissingArg)
SETCAR(argList, mkString(""));
if(CADR(argList) == R_MissingArg)
SETCAR(CDR(argList), R_NilValue);
if(CADDR(argList) == R_MissingArg)
SETCAR(CDDR(argList), ScalarLogical(1));
if(CADDDR(argList) == R_MissingArg)
SETCAR(CDDDR(argList), ScalarInteger(0));
/* return if 'expr' is not TRUE */
if( !asLogical(CADDR(argList)) ) {
UNPROTECT(1);
return R_NilValue;
}
/* Save the evaluator state information */
/* so that it can be restored on exit. */
browselevel = countContexts(CTXT_BROWSER, 1);
savestack = R_PPStackTop;
PROTECT(topExp = R_CurrentExpr);
saveToplevelContext = R_ToplevelContext;
saveGlobalContext = R_GlobalContext;
if (!RDEBUG(rho)) {
int skipCalls = asInteger(CADDDR(argList));
cptr = R_GlobalContext;
while ( ( !(cptr->callflag & CTXT_FUNCTION) || skipCalls--)
&& cptr->callflag )
cptr = cptr->nextcontext;
Rprintf("Called from: ");
int tmp = asInteger(GetOption(install("deparse.max.lines"), R_BaseEnv));
if(tmp != NA_INTEGER && tmp > 0) R_BrowseLines = tmp;
if( cptr != R_ToplevelContext ) {
PrintValueRec(cptr->call, rho);
SET_RDEBUG(cptr->cloenv, 1);
} else
Rprintf("top level \n");
R_BrowseLines = 0;
}
R_ReturnedValue = R_NilValue;
/* Here we establish two contexts. The first */
/* of these provides a target for return */
/* statements which a user might type at the */
/* browser prompt. The (optional) second one */
/* acts as a target for error returns. */
begincontext(&returncontext, CTXT_BROWSER, call, rho,
R_BaseEnv, argList, R_NilValue);
if (!SETJMP(returncontext.cjmpbuf)) {
begincontext(&thiscontext, CTXT_RESTART, R_NilValue, rho,
R_BaseEnv, R_NilValue, R_NilValue);
if (SETJMP(thiscontext.cjmpbuf)) {
SET_RESTART_BIT_ON(thiscontext.callflag);
R_ReturnedValue = R_NilValue;
R_Visible = FALSE;
}
R_GlobalContext = &thiscontext;
R_InsertRestartHandlers(&thiscontext, TRUE);
R_ReplConsole(rho, savestack, browselevel+1);
endcontext(&thiscontext);
}
endcontext(&returncontext);
/* Reset the interpreter state. */
R_CurrentExpr = topExp;
UNPROTECT(1);
R_PPStackTop = savestack;
UNPROTECT(1);
R_CurrentExpr = topExp;
R_ToplevelContext = saveToplevelContext;
R_GlobalContext = saveGlobalContext;
return R_ReturnedValue;
}
