/*
* call to numeric_deriv from R -
* .Call("numeric_deriv", expr, theta, rho)
* Returns: ans
*/
SEXP
numeric_deriv(SEXP expr, SEXP theta, SEXP rho, SEXP dir)
{
SEXP ans, gradient, pars;
double eps = sqrt(DOUBLE_EPS), *rDir;
int start, i, j, k, lengthTheta = 0;
if(!isString(theta))
error(_("'theta' should be of type character"));
if (isNull(rho)) {
error(_("use of NULL environment is defunct"));
rho = R_BaseEnv;
} else
if(!isEnvironment(rho))
error(_("'rho' should be an environment"));
PROTECT(dir = coerceVector(dir, REALSXP));
if(TYPEOF(dir) != REALSXP || LENGTH(dir) != LENGTH(theta))
error(_("'dir' is not a numeric vector of the correct length"));
rDir = REAL(dir);
PROTECT(pars = allocVector(VECSXP, LENGTH(theta)));
PROTECT(ans = duplicate(eval(expr, rho)));
if(!isReal(ans)) {
SEXP temp = coerceVector(ans, REALSXP);
UNPROTECT(1);
PROTECT(ans = temp);
}
for(i = 0; i < LENGTH(ans); i++) {
if (!R_FINITE(REAL(ans)[i]))
error(_("Missing value or an infinity produced when evaluating the model"));
}
const void *vmax = vmaxget();
for(i = 0; i < LENGTH(theta); i++) {
const char *name = translateChar(STRING_ELT(theta, i));
SEXP s_name = install(name);
SEXP temp = findVar(s_name, rho);
if(isInteger(temp))
error(_("variable '%s' is integer, not numeric"), name);
if(!isReal(temp))
error(_("variable '%s' is not numeric"), name);
if (MAYBE_SHARED(temp)) /* We'll be modifying the variable, so need to make sure it's unique PR#15849 */
defineVar(s_name, temp = duplicate(temp), rho);
MARK_NOT_MUTABLE(temp);
SET_VECTOR_ELT(pars, i, temp);
lengthTheta += LENGTH(VECTOR_ELT(pars, i));
}
vmaxset(vmax);
PROTECT(gradient = allocMatrix(REALSXP, LENGTH(ans), lengthTheta));
for(i = 0, start = 0; i < LENGTH(theta); i++) {
for(j = 0; j < LENGTH(VECTOR_ELT(pars, i)); j++, start += LENGTH(ans)) {
SEXP ans_del;
double origPar, xx, delta;
origPar = REAL(VECTOR_ELT(pars, i))[j];
xx = fabs(origPar);
delta = (xx == 0) ? eps : xx*eps;
REAL(VECTOR_ELT(pars, i))[j] += rDir[i] * delta;
PROTECT(ans_del = eval(expr, rho));
if(!isReal(ans_del)) ans_del = coerceVector(ans_del, REALSXP);
UNPROTECT(1);
for(k = 0; k < LENGTH(ans); k++) {
if (!R_FINITE(REAL(ans_del)[k]))
error(_("Missing value or an infinity produced when evaluating the model"));
REAL(gradient)[start + k] =
rDir[i] * (REAL(ans_del)[k] - REAL(ans)[k])/delta;
}
REAL(VECTOR_ELT(pars, i))[j] = origPar;
}
}
setAttrib(ans, install("gradient"), gradient);
UNPROTECT(4);
return ans;
}
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 DropDims(SEXP x)
{
SEXP dims, dimnames, newnames = R_NilValue;
int i, n, ndims;
PROTECT(x);
dims = getDimAttrib(x);
dimnames = getDimNamesAttrib(x);
/* Check that dropping will actually do something. */
/* (1) Check that there is a "dim" attribute. */
if (dims == R_NilValue) {
UNPROTECT(1);
return x;
}
ndims = LENGTH(dims);
/* (2) Check whether there are redundant extents */
n = 0;
for (i = 0; i < ndims; i++)
if (INTEGER(dims)[i] != 1) n++;
if (n == ndims) {
UNPROTECT(1);
return x;
}
if (n <= 1) {
/* We have reduced to a vector result.
If that has length one, it is ambiguous which dimnames to use,
so use it if there is only one (as from R 2.7.0).
*/
if (dimnames != R_NilValue) {
if(XLENGTH(x) != 1) {
for (i = 0; i < LENGTH(dims); i++) {
if (INTEGER(dims)[i] != 1) {
newnames = VECTOR_ELT(dimnames, i);
break;
}
}
} else { /* drop all dims: keep names if unambiguous */
int cnt;
for(i = 0, cnt = 0; i < LENGTH(dims); i++)
if(VECTOR_ELT(dimnames, i) != R_NilValue) cnt++;
if(cnt == 1)
for (i = 0; i < LENGTH(dims); i++) {
newnames = VECTOR_ELT(dimnames, i);
if(newnames != R_NilValue) break;
}
}
}
PROTECT(newnames);
setAttrib(x, R_DimNamesSymbol, R_NilValue);
setAttrib(x, R_DimSymbol, R_NilValue);
setAttrib(x, R_NamesSymbol, newnames);
/* FIXME: the following is desirable, but pointless as long as
subset.c & others have a contrary version that leaves the
S4 class in, incorrectly, in the case of vectors. JMC
3/3/09 */
/* if(IS_S4_OBJECT(x)) {/\* no longer valid subclass of array or
matrix *\/ */
/* setAttrib(x, R_ClassSymbol, R_NilValue); */
/* UNSET_S4_OBJECT(x); */
/* } */
UNPROTECT(1);
} else {
/* We have a lower dimensional array. */
SEXP newdims, dnn, newnamesnames = R_NilValue;
dnn = getNamesAttrib(dimnames);
PROTECT(newdims = allocVector(INTSXP, n));
for (i = 0, n = 0; i < ndims; i++)
if (INTEGER(dims)[i] != 1)
INTEGER(newdims)[n++] = INTEGER(dims)[i];
if (!isNull(dimnames)) {
int havenames = 0;
for (i = 0; i < ndims; i++)
if (INTEGER(dims)[i] != 1 &&
VECTOR_ELT(dimnames, i) != R_NilValue)
havenames = 1;
if (havenames) {
PROTECT(newnames = allocVector(VECSXP, n));
PROTECT(newnamesnames = allocVector(STRSXP, n));
for (i = 0, n = 0; i < ndims; i++) {
if (INTEGER(dims)[i] != 1) {
if(!isNull(dnn))
SET_STRING_ELT(newnamesnames, n,
STRING_ELT(dnn, i));
SET_VECTOR_ELT(newnames, n++, VECTOR_ELT(dimnames, i));
}
}
}
else dimnames = R_NilValue;
}
PROTECT(dimnames);
setAttrib(x, R_DimNamesSymbol, R_NilValue);
setAttrib(x, R_DimSymbol, newdims);
if (dimnames != R_NilValue)
{
if(!isNull(dnn))
setAttrib(newnames, R_NamesSymbol, newnamesnames);
setAttrib(x, R_DimNamesSymbol, newnames);
UNPROTECT(2);
}
UNPROTECT(2);
}
UNPROTECT(1);
return x;
}
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 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);
}
/*
Given a minc filename, return a list containing:
(1) the dimension names
(2) the dimension sizes
(3) and much, much more
*/
SEXP get_volume_info(SEXP filename) {
mihandle_t minc_volume;
midimhandle_t *dimensions;
miclass_t volume_class;
mitype_t volume_type;
int result, i;
int n_dimensions;
misize_t n_dimensions_misize_t;
int n_protects, list_index;
int n_frames;
// variables to hold dim-related info
misize_t dim_sizes[MI2_MAX_VAR_DIMS];
double dim_starts[MI2_MAX_VAR_DIMS];
double dim_steps[MI2_MAX_VAR_DIMS];
double time_offsets[MAX_FRAMES];
double time_widths[MAX_FRAMES];
char *dim_name;
char *dim_units;
char *space_type;
Rboolean time_dim_exists;
static char *dimorder3d[] = { "zspace","yspace","xspace" };
static char *dimorder4d[] = { "time", "zspace","yspace","xspace" };
/* declare R datatypes */
SEXP rtnList, listNames;
SEXP xDimSizes, xDimNames, xDimUnits, xDimStarts, xDimSteps, xTimeWidths, xTimeOffsets;
// start ...
if ( R_DEBUG_mincIO ) Rprintf("get_volume_info: start ...\n");
/* do some initialization */
for (i=0; i < MI2_MAX_VAR_DIMS; ++i){ // set dim info to zeros
dim_sizes[i] = 0;
dim_starts[i] = 0;
dim_steps[i] = 0;
}
// frame-related init
time_dim_exists = FALSE;
for (i=0; i < MAX_FRAMES; ++i) {
time_offsets[i]=999.9;
time_widths[i]=999.9;
}
n_frames = 0;
n_protects = 0; // counter of protected R variables
/* init the return list (include list names) */
PROTECT(rtnList=allocVector(VECSXP, R_RTN_LIST_LEN));
PROTECT(listNames=allocVector(STRSXP, R_RTN_LIST_LEN));
n_protects = n_protects +2;
/* open the existing volume */
result = miopen_volume(CHAR(STRING_ELT(filename,0)), MI2_OPEN_READ, &minc_volume);
/* error on open? */
if (result != MI_NOERROR) {
error("Error opening input file: %s.\n", CHAR(STRING_ELT(filename,0)));
}
/* set the apparent order to something conventional */
// ... first need to get the number of dimensions
if ( miget_volume_dimension_count(minc_volume, MI_DIMCLASS_ANY, MI_DIMATTR_ALL, &n_dimensions) != MI_NOERROR ){
error("Error returned from miget_volume_dimension_count.\n");
}
n_dimensions_misize_t = (misize_t) n_dimensions;
// ... now set the order
if ( R_DEBUG_mincIO ) Rprintf("Setting the apparent order for %d dimensions ... ", n_dimensions);
if ( n_dimensions == 3 ) {
result = miset_apparent_dimension_order_by_name(minc_volume, 3, dimorder3d);
} else if ( n_dimensions == 4 ) {
result = miset_apparent_dimension_order_by_name(minc_volume, 4, dimorder4d);
} else {
error("Error file %s has %d dimensions and we can only deal with 3 or 4.\n", CHAR(STRING_ELT(filename,0)), n_dimensions);
}
if ( result != MI_NOERROR ) {
error("Error returned from miset_apparent_dimension_order_by_name while setting apparent order for %d dimensions.\n", n_dimensions);
}
if ( R_DEBUG_mincIO ) Rprintf("Done.\n");
/* get the volume data class (the intended "real" values) */
if ( miget_data_class(minc_volume, &volume_class) != MI_NOERROR ){
error("Error returned from miget_data_class.\n");
}
/* append to return list ... */
list_index = 0;
SET_VECTOR_ELT(rtnList, list_index, ScalarInteger(volume_class));
SET_STRING_ELT(listNames, list_index, mkChar("volumeDataClass"));
/* print the volume data type (as it is actually stored in the volume) */
if ( miget_data_type(minc_volume, &volume_type) != MI_NOERROR ){
error("Error returned from miget_data_type.\n");
}
/* append to return list ... */
list_index++;
SET_VECTOR_ELT(rtnList, list_index, ScalarInteger(volume_type));
SET_STRING_ELT(listNames, list_index, mkChar("volumeDataType"));
/* retrieve the volume space type (talairach, native, etc) */
result = miget_space_name(minc_volume, &space_type);
if ( result == MI_NOERROR ) { error("Error returned from miget_space_name.\n"); }
/* append to return list ... */
list_index++;
SET_VECTOR_ELT(rtnList, list_index, mkString(space_type));
SET_STRING_ELT(listNames, list_index, mkChar("spaceType"));
/* retrieve the total number of dimensions in this volume */
if ( miget_volume_dimension_count(minc_volume, MI_DIMCLASS_ANY, MI_DIMATTR_ALL, &n_dimensions) != MI_NOERROR ){
error("Error returned from miget_volume_dimension_count.\n");
}
/* append to return list ... */
list_index++;
SET_VECTOR_ELT(rtnList, list_index, ScalarInteger(n_dimensions));
SET_STRING_ELT(listNames, list_index, mkChar("nDimensions"));
/* load up dimension-related information */
//
/* first allocate the R variables */
PROTECT( xDimSizes=allocVector(INTSXP,n_dimensions) );
PROTECT( xDimNames=allocVector(STRSXP,n_dimensions) );
PROTECT( xDimUnits=allocVector(STRSXP,n_dimensions) );
PROTECT( xDimStarts=allocVector(REALSXP,n_dimensions) );
PROTECT( xDimSteps=allocVector(REALSXP,n_dimensions) );
n_protects = n_protects +5;
/* next, load up the midimension struct for all dimensions*/
dimensions = (midimhandle_t *) malloc( sizeof( midimhandle_t ) * n_dimensions );
result = miget_volume_dimensions(minc_volume, MI_DIMCLASS_ANY, MI_DIMATTR_ALL, MI_DIMORDER_APPARENT, n_dimensions, dimensions);
// need to check against MI_ERROR, as "result" will contain nDimensions if OK
if ( result == MI_ERROR ) { error("Error code(%d) returned from miget_volume_dimensions.\n", result); }
/* get the dimension sizes for all dimensions */
result = miget_dimension_sizes(dimensions, n_dimensions_misize_t, dim_sizes);
if ( result != MI_NOERROR ) { error("Error returned from miget_dimension_sizes.\n"); }
/* add to R vector ... */
for (i=0; i<n_dimensions; ++i){
INTEGER(xDimSizes)[i] = dim_sizes[i];
}
list_index++;
SET_VECTOR_ELT(rtnList, list_index, xDimSizes);
SET_STRING_ELT(listNames, list_index, mkChar("dimSizes"));
/* get the dimension START values for all dimensions */
result = miget_dimension_starts(dimensions, MI_ORDER_FILE, n_dimensions, dim_starts);
if ( result == MI_ERROR ) { error("Error returned from miget_dimension_starts.\n"); }
/* add to R vector ... */
for (i=0; i<n_dimensions; ++i){
REAL(xDimStarts)[i] = dim_starts[i];
}
list_index++;
SET_VECTOR_ELT(rtnList, list_index, xDimStarts);
SET_STRING_ELT(listNames, list_index, mkChar("dimStarts"));
/* get the dimension STEP values for all dimensions */
result = miget_dimension_separations(dimensions, MI_ORDER_FILE, n_dimensions, dim_steps);
if ( result == MI_ERROR ) { error("Error returned from miget_dimension_separations.\n"); }
/* add to R vector ... */
for (i=0; i<n_dimensions; ++i){
REAL(xDimSteps)[i] = dim_steps[i];
}
list_index++;
SET_VECTOR_ELT(rtnList, list_index, xDimSteps);
SET_STRING_ELT(listNames, list_index, mkChar("dimSteps"));
/* Loop over the dimensions to grab the remaining info ... */
for( i=0; i < n_dimensions; ++i ){
//
/* get (and print) the dimension names for all dimensions*
... remember that since miget_dimension_name calls strdup which, in turn,
... calls malloc to get memory for the new string -- we need to call "mifree" on
... our pointer to release that memory. */
result = miget_dimension_name(dimensions[i], &dim_name);
// do we have a time dimension?
if ( !strcmp(dim_name, "time") ) {
time_dim_exists = TRUE;
n_frames = ( time_dim_exists ) ? dim_sizes[0] : 0;
}
// store the dimension name and units
SET_STRING_ELT(xDimNames, i, mkChar(dim_name));
mifree_name(dim_name);
result = miget_dimension_units(dimensions[i], &dim_units);
SET_STRING_ELT(xDimUnits, i, mkChar(dim_units));
mifree_name(dim_units);
}
/* add number of frames to return list */
list_index++;
SET_VECTOR_ELT(rtnList, list_index, ScalarInteger(n_frames));
SET_STRING_ELT(listNames, list_index, mkChar("nFrames"));
// add dim names to return list
list_index++;
SET_VECTOR_ELT(rtnList, list_index, xDimNames);
SET_STRING_ELT(listNames, list_index, mkChar("dimNames"));
// add dim units
list_index++;
SET_VECTOR_ELT(rtnList, list_index, xDimUnits);
SET_STRING_ELT(listNames, list_index, mkChar("dimUnits"));
/* get the dimension OFFSETS values for the TIME dimension */
if ( time_dim_exists ) {
PROTECT( xTimeOffsets=allocVector(REALSXP,n_frames) );
n_protects++;
result = miget_dimension_offsets(dimensions[0], n_frames, 0, time_offsets);
if ( result == MI_ERROR ) { error("Error returned from miget_dimension_offsets.\n"); }
/* add to R vector ... */
for (i=0; i < n_frames; ++i) {
REAL(xTimeOffsets)[i] = time_offsets[i];
// if (R_DEBUG_mincIO) Rprintf("Time offset[%d] = %g\n", i, time_offsets[i]);
}
list_index++;
SET_VECTOR_ELT(rtnList, list_index, xTimeOffsets);
SET_STRING_ELT(listNames, list_index, mkChar("timeOffsets"));
/* get the dimension WIDTH values for the TIME dimension */
PROTECT( xTimeWidths=allocVector(REALSXP,n_frames) );
n_protects++;
result = miget_dimension_widths(dimensions[0], MI_ORDER_FILE, n_frames, 0, time_widths);
if ( result == MI_ERROR ) { error("Error returned from miget_dimension_widths.\n"); }
/* add to R vector ... */
for (i=0; i<n_frames; ++i) {
REAL(xTimeWidths)[i] = time_widths[i];
// if (R_DEBUG_mincIO) Rprintf("Time width[%d] = %g\n", i, time_widths[i]);
}
list_index++;
SET_VECTOR_ELT(rtnList, list_index, xTimeWidths);
SET_STRING_ELT(listNames, list_index, mkChar("timeWidths"));
}
// free heap memory
free(dimensions);
/* close volume */
miclose_volume(minc_volume);
/* attach the list component names to the list */
setAttrib(rtnList, R_NamesSymbol, listNames);
/* remove gc collection protection */
UNPROTECT(n_protects);
/* return */
if ( R_DEBUG_mincIO ) Rprintf("get_volume_info: returning ...\n");
return(rtnList);
}
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;
}
/* generate a graph with given node ordering and arc probability. */
SEXP ordered_graph(SEXP nodes, SEXP num, SEXP prob) {
int i = 0, j = 0, k = 0, nnodes = LENGTH(nodes), *a = NULL, *n = INTEGER(num);
double *p = REAL(prob);
SEXP list, res, args, argnames, amat, arcs, cached, debug2, null, temp;
/* a fake debug argument (set to FALSE) for cache_structure(). */
PROTECT(debug2 = allocVector(LGLSXP, 1));
LOGICAL(debug2)[0] = FALSE;
/* the list of optional arguments. */
PROTECT(argnames = allocVector(STRSXP, 1));
SET_STRING_ELT(argnames, 0, mkChar("prob"));
PROTECT(args = allocVector(VECSXP, 1));
setAttrib(args, R_NamesSymbol, argnames);
SET_VECTOR_ELT(args, 0, prob);
/* allocate and initialize the adjacency matrix. */
PROTECT(amat = allocMatrix(INTSXP, nnodes, nnodes));
a = INTEGER(amat);
memset(a, '\0', nnodes * nnodes * sizeof(int));
GetRNGstate();
#define ORDERED_AMAT(prob) \
for (i = 0; i < nnodes; i++) \
for (j = i + 1; j < nnodes; j++) \
if (unif_rand() < prob) \
a[CMC(i, j, nnodes)] = 1; \
else \
a[CMC(i, j, nnodes)] = 0; \
/* return a list if more than one bn is generated. */
if (*n > 1) {
PROTECT(list = allocVector(VECSXP, *n));
PROTECT(null = allocVector(NILSXP, 1));
/* generate the "bn" structure, with dummy NULLs for the "arcs" and
* "nodes" elements (which will be initialized later on). */
PROTECT(res = bn_base_structure(nodes, args, null, null, 0, "none", "ordered"));
for (k = 0; k < *n; k++) {
/* sample each arc in the upper-triangular portion of the adjacency matrix
* (so that node ordering is conserved) with the specified probability. */
ORDERED_AMAT(*p);
/* generate the arc set and the cached information form the adjacency
* matrix. */
PROTECT(arcs = amat2arcs(amat, nodes));
PROTECT(cached = cache_structure(nodes, amat, debug2));
SET_VECTOR_ELT(res, 1, cached);
SET_VECTOR_ELT(res, 2, arcs);
/* save the structure in the list. */
PROTECT(temp = duplicate(res));
SET_VECTOR_ELT(list, k, temp);
UNPROTECT(3);
}/*FOR*/
PutRNGstate();
UNPROTECT(7);
return list;
}/*THEN*/
else {
/* sample each arc in the upper-triangular portion of the adjacency matrix
* (so that node ordering is conserved) with the specified probability. */
ORDERED_AMAT(*p);
/* generate the arc set and the cached information form the adjacency
* matrix. */
PROTECT(arcs = amat2arcs(amat, nodes));
PROTECT(cached = cache_structure(nodes, amat, debug2));
/* generate the "bn" structure. */
PROTECT(res = bn_base_structure(nodes, args, arcs, cached, 0, "none", "ordered"));
PutRNGstate();
UNPROTECT(7);
return res;
}/*ELSE*/
}/*ORDERED_GRAPH*/
SEXP Scatt( const SEXP data_sxp, // data matrix
const SEXP clusters_sxp, // vector with information about clusters (object num. -> cluster)
const SEXP clust_num_sxp, // number of clusters (table with one element)
const SEXP choosen_metric_sxp // number representing choosen metric
)
{
// additional variables especially needed in loops and in functions as parameters
int i, j, obj_num, dim_num, clust_num, protect_num;
// define distance between choosen objects
double dist;
protect_num = 0;
// declaration of intracluster distances (vectors)
SEXP mean_sxp, variance_sxp;
double *mean, *variance;
// matrix (and pointer to the table) with cluster centers
SEXP cluster_center_sxp, cluster_variance_sxp, cluster_size_sxp;
double *cluster_center, *cluster_variance;
int *cluster_size;
// table - which object belongs to which cluster
int *cluster_tab = INTEGER(clusters_sxp);
// get information about data matrix
SEXP dim = NILSXP;
PROTECT( dim = getAttrib(data_sxp, R_DimSymbol) );
protect_num++;
obj_num = INTEGER(dim)[0];
dim_num = INTEGER(dim)[1];
// and number of clusters
clust_num = INTEGER(clust_num_sxp)[0];
// compute mean
PROTECT( mean_sxp = clv_mean(data_sxp, obj_num, dim_num) );
protect_num++;
// and variance
PROTECT( variance_sxp = clv_variance(data_sxp, obj_num, dim_num, mean_sxp) );
protect_num++;
variance = REAL(variance_sxp);
// vector with information about size of each cluster
PROTECT( cluster_size_sxp = clv_clustersSize(clusters_sxp, clust_num) );
protect_num++;
cluster_size = INTEGER(cluster_size_sxp);
PROTECT( cluster_center_sxp = clv_clusterCenters(data_sxp, obj_num, dim_num, clust_num, cluster_tab, cluster_size) );
protect_num++;
PROTECT( cluster_variance_sxp = clv_clusterVariance(data_sxp, obj_num, dim_num, clust_num, cluster_tab, cluster_size, cluster_center_sxp) );
protect_num++;
cluster_variance = REAL(cluster_variance_sxp);
double sum_cls_var_norm = 0, tmp;
int pos;
// compute "stdev" value ( sum[ forall k in {1, ... ,cluster num.} ] ||sigma(C_k)||)
for(i=0; i<clust_num; i++)
{
sum_cls_var_norm += clv_norm(cluster_variance, i, dim_num, clust_num);
}
// compute norm of variance of dataset (||sigma(X)||)
double var_norm = clv_norm(variance, 0, dim_num, 1); ;
SEXP Scatt, stdev;
PROTECT( Scatt = allocVector(REALSXP, 1) );
protect_num++;
PROTECT( stdev = allocVector(REALSXP, 1) );
protect_num++;
REAL(Scatt)[0] = sum_cls_var_norm/(clust_num*var_norm);
REAL(stdev)[0] = sqrt(sum_cls_var_norm)/clust_num;
// time to gather all particular indicies into one result list
int list_elem_num = 3;
SEXP result_list;
PROTECT( result_list = allocVector(VECSXP, list_elem_num) );
protect_num++;
SEXP names;
PROTECT( names = allocVector(STRSXP, list_elem_num) );
protect_num++;
pos = 0;
SET_STRING_ELT( names, pos++, mkChar("Scatt") );
SET_STRING_ELT( names, pos++, mkChar("stdev") );
SET_STRING_ELT( names, pos++, mkChar("cluster.center") );
setAttrib( result_list, R_NamesSymbol, names );
pos = 0;
SET_VECTOR_ELT( result_list, pos++, Scatt );
SET_VECTOR_ELT( result_list, pos++, stdev );
SET_VECTOR_ELT( result_list, pos++, cluster_center_sxp );
UNPROTECT(protect_num);
return result_list;
}
/* an Ide-Cozman alternative for 2-nodes graphs. */
static SEXP ic_2nodes(SEXP nodes, SEXP num, SEXP burn_in, SEXP max_in_degree,
SEXP max_out_degree, SEXP max_degree, SEXP connected, SEXP debug) {
int i = 0, *n = INTEGER(num), *a = NULL;
int *debuglevel = LOGICAL(debug);
double u = 0;
SEXP list, resA, resB, arcsA, arcsB, cachedA, cachedB;
SEXP amatA, amatB, args, argnames, false;
/* the list of optional arguments. */
PROTECT(argnames = allocVector(STRSXP, 4));
SET_STRING_ELT(argnames, 0, mkChar("burn.in"));
SET_STRING_ELT(argnames, 1, mkChar("max.in.degree"));
SET_STRING_ELT(argnames, 2, mkChar("max.out.degree"));
SET_STRING_ELT(argnames, 3, mkChar("max.degree"));
PROTECT(args = allocVector(VECSXP, 4));
setAttrib(args, R_NamesSymbol, argnames);
SET_VECTOR_ELT(args, 0, burn_in);
SET_VECTOR_ELT(args, 1, max_in_degree);
SET_VECTOR_ELT(args, 2, max_out_degree);
SET_VECTOR_ELT(args, 3, max_degree);
/* allocate a FALSE variable. */
PROTECT(false = allocVector(LGLSXP, 1));
LOGICAL(false)[0] = FALSE;
/* allocate and initialize the tow adjacency matrices. */
PROTECT(amatA = allocMatrix(INTSXP, 2, 2));
a = INTEGER(amatA);
memset(a, '\0', sizeof(int) * 4);
a[2] = 1;
PROTECT(amatB = allocMatrix(INTSXP, 2, 2));
a = INTEGER(amatB);
memset(a, '\0', sizeof(int) * 4);
a[1] = 1;
/* generates the arc sets. */
PROTECT(arcsA = amat2arcs(amatA, nodes));
PROTECT(arcsB = amat2arcs(amatB, nodes));
/* generate the cached node information. */
PROTECT(cachedA = cache_structure(nodes, amatA, false));
PROTECT(cachedB = cache_structure(nodes, amatB, false));
/* generate the two "bn" structures. */
PROTECT(resA = bn_base_structure(nodes, args, arcsA, cachedA, 0, "none", "empty"));
PROTECT(resB = bn_base_structure(nodes, args, arcsB, cachedB, 0, "none", "empty"));
if (*debuglevel > 0)
Rprintf("* no burn-in required.\n");
GetRNGstate();
/* return a list if more than one bn is generated. */
if (*n > 1) {
PROTECT(list = allocVector(VECSXP, *n));
for (i = 0; i < *n; i++) {
if (*debuglevel > 0)
Rprintf("* current model (%d):\n", i + 1);
/* sample which graph to return. */
u = unif_rand();
if (u <= 0.5) {
/* pick the graph with A -> B. */
SET_VECTOR_ELT(list, i, resA);
/* print the model string to allow a sane debugging experience. */
if (*debuglevel > 0)
print_modelstring(resA);
}/*THEN*/
else {
/* pick the graph with B -> A. */
SET_VECTOR_ELT(list, i, resB);
/* print the model string to allow a sane debugging experience. */
if (*debuglevel > 0)
print_modelstring(resB);
}/*ELSE*/
}/*FOR*/
PutRNGstate();
UNPROTECT(12);
return list;
}/*THEN*/
else {
if (*debuglevel > 0)
Rprintf("* current model (1):\n");
/* sample which graph to return. */
u = unif_rand();
PutRNGstate();
UNPROTECT(11);
if (u <= 0.5) {
/* print the model string to allow a sane debugging experience. */
if (*debuglevel > 0)
print_modelstring(resA);
/* return the graph with A -> B. */
return resA;
}/*THEN*/
else {
/* print the model string to allow a sane debugging experience. */
if (*debuglevel > 0)
print_modelstring(resB);
/* return the graph with B -> A. */
return resB;
}/*ELSE*/
}/*ELSE*/
}/*IC_2NODES*/
static SEXP c_ide_cozman(SEXP nodes, SEXP num, SEXP burn_in, SEXP max_in_degree,
SEXP max_out_degree, SEXP max_degree, SEXP connected, SEXP debug) {
int i = 0, k = 0, nnodes = LENGTH(nodes), *n = INTEGER(num);
int changed = 0, *work = NULL, *arc = NULL, *a = NULL, *burn = INTEGER(burn_in);
int *degree = NULL, *in_degree = NULL, *out_degree = NULL;
int *debuglevel = LOGICAL(debug), *cozman = LOGICAL(connected);
double *max_in = REAL(max_in_degree), *max_out = REAL(max_out_degree),
*max = REAL(max_degree);
SEXP list, res, args, argnames, amat, arcs, cached, debug2, null, temp;
char *label = (*cozman > 0) ? "ic-dag" : "melancon";
/* a fake debug argument (set to FALSE) for cache_structure(). */
PROTECT(debug2 = allocVector(LGLSXP, 1));
LOGICAL(debug2)[0] = FALSE;
/* the list of optional arguments. */
PROTECT(argnames = allocVector(STRSXP, 4));
SET_STRING_ELT(argnames, 0, mkChar("burn.in"));
SET_STRING_ELT(argnames, 1, mkChar("max.in.degree"));
SET_STRING_ELT(argnames, 2, mkChar("max.out.degree"));
SET_STRING_ELT(argnames, 3, mkChar("max.degree"));
PROTECT(args = allocVector(VECSXP, 4));
setAttrib(args, R_NamesSymbol, argnames);
SET_VECTOR_ELT(args, 0, burn_in);
SET_VECTOR_ELT(args, 1, max_in_degree);
SET_VECTOR_ELT(args, 2, max_out_degree);
SET_VECTOR_ELT(args, 3, max_degree);
/* allocate and initialize the adjacency matrix. */
PROTECT(amat = allocMatrix(INTSXP, nnodes, nnodes));
a = INTEGER(amat);
memset(a, '\0', nnodes * nnodes * sizeof(int));
/* initialize a simple ordered tree with n nodes, where all nodes
* have just one parent, except the first one that does not have
* any parent. */
for (i = 1; i < nnodes; i++)
a[CMC(i - 1, i, nnodes)] = 1;
/* allocate the arrays needed by SampleNoReplace. */
arc = alloc1dcont(2);
work = alloc1dcont(nnodes);
/* allocate and initialize the degree arrays. */
degree = alloc1dcont(nnodes);
in_degree = alloc1dcont(nnodes);
out_degree = alloc1dcont(nnodes);
for (i = 0; i < nnodes; i++) {
in_degree[i] = out_degree[i] = 1;
degree[i] = 2;
}/*FOR*/
in_degree[0] = out_degree[nnodes - 1] = 0;
degree[0] = degree[nnodes - 1] = 1;
GetRNGstate();
/* wait for the markov chain monte carlo simulation to reach stationarity. */
for (k = 0; k < *burn; k++) {
if (*debuglevel > 0)
Rprintf("* current model (%d):\n", k + 1);
changed = ic_logic(a, nodes, &nnodes, arc, work, degree, max, in_degree, max_in,
out_degree, max_out, cozman, debuglevel);
/* print the model string to allow a sane debugging experience; note that this
* has a huge impact on performance, so use it with care. */
if ((*debuglevel > 0) && (changed)) {
PROTECT(null = allocVector(NILSXP, 1));
PROTECT(res = bn_base_structure(nodes, args, null, null, 0, "none", label));
PROTECT(arcs = amat2arcs(amat, nodes));
PROTECT(cached = cache_structure(nodes, amat, debug2));
SET_VECTOR_ELT(res, 1, cached);
SET_VECTOR_ELT(res, 2, arcs);
print_modelstring(res);
UNPROTECT(4);
}/*THEN*/
}/*FOR*/
#define UPDATE_NODE_CACHE(cur) \
if (*debuglevel > 0) \
Rprintf(" > updating cached information about node %s.\n", NODE(cur)); \
memset(work, '\0', nnodes * sizeof(int)); \
PROTECT(temp = c_cache_partial_structure(cur, nodes, amat, work, debug2)); \
SET_VECTOR_ELT(cached, cur, temp); \
UNPROTECT(1);
/* return a list if more than one bn is generated. */
if (*n > 1) {
if (*debuglevel > 0)
Rprintf("* end of the burn-in iterations.\n");
PROTECT(list = allocVector(VECSXP, *n));
PROTECT(null = allocVector(NILSXP, 1));
/* generate the "bn" structure, with dummy NULLs for the "arcs" and
* "nodes" elements (which will be initialized later on). */
PROTECT(res = bn_base_structure(nodes, args, null, null, 0, "none", label));
for (k = 0; k < *n; k++) {
if (*debuglevel > 0)
Rprintf("* current model (%d):\n", *burn + k + 1);
changed = ic_logic(a, nodes, &nnodes, arc, work, degree, max, in_degree,
max_in, out_degree, max_out, cozman, debuglevel);
if (changed || (k == 0)) {
/* generate the arc set and the cached information from the adjacency
* matrix. */
if (k > 0) {
/* if a complete "bn" object is available, we can retrieve the cached
* information about the nodes from the structure stored in the last
* iteration and update only the elements that really need it. */
temp = VECTOR_ELT(VECTOR_ELT(list, k - 1), 1);
PROTECT(cached = duplicate(temp));
/* update the first sampled nodes; both of them gain/lose either
* a parent or a child. */
UPDATE_NODE_CACHE(arc[0] - 1);
UPDATE_NODE_CACHE(arc[1] - 1);
/* all the parents of the second sampled node gain/lose a node in
* the markov blanket (the first sampled node, which shares a child
* with all of them). */
for (i = 0; i < nnodes; i++) {
if ((i != arc[0] - 1) && (a[CMC(i, arc[1] - 1, nnodes)] == 1)) {
UPDATE_NODE_CACHE(i);
}/*THEN*/
}/*FOR*/
}/*THEN*/
else {
PROTECT(cached = cache_structure(nodes, amat, debug2));
}/*ELSE*/
PROTECT(arcs = amat2arcs(amat, nodes));
SET_VECTOR_ELT(res, 1, cached);
SET_VECTOR_ELT(res, 2, arcs);
/* print the model string to allow a sane debugging experience. */
if (*debuglevel > 0)
print_modelstring(res);
/* save the structure in the list. */
PROTECT(temp = duplicate(res));
SET_VECTOR_ELT(list, k, temp);
UNPROTECT(3);
}/*THEN*/
else {
/* the adjacency matrix is unchanged; so we can just copy the bayesian
* network from the previous iteration in the k-th slot of the list. */
SET_VECTOR_ELT(list, k, VECTOR_ELT(list, k - 1));
}/*ELSE*/
}/*FOR*/
PutRNGstate();
UNPROTECT(7);
return list;
}/*THEN*/
else {
if (*debuglevel > 0)
Rprintf("* end of the burn-in.\n* current model (%d):\n", *burn + 1);
ic_logic(a, nodes, &nnodes, arc, work, degree, max, in_degree,
max_in, out_degree, max_out, cozman, debuglevel);
/* generate the arc set and the cached information form the adjacency
* matrix. */
PROTECT(arcs = amat2arcs(amat, nodes));
PROTECT(cached = cache_structure(nodes, amat, debug2));
/* generate the "bn" structure. */
PROTECT(res = bn_base_structure(nodes, args, arcs, cached, 0, "none", label));
/* print the model string to allow a sane debugging experience. */
if (*debuglevel > 0)
print_modelstring(res);
PutRNGstate();
UNPROTECT(7);
return res;
}/*ELSE*/
}/*C_IDE_COZMAN*/
/* generate an empty graph. */
SEXP empty_graph(SEXP nodes, SEXP num) {
int i = 0, nnodes = LENGTH(nodes), *n = INTEGER(num);
SEXP list, res, args, arcs, cached;
SEXP dimnames, colnames, elnames, base, base2;
/* an empty list of optional arguments. */
PROTECT(args = allocVector(VECSXP, 0));
/* names for the arc set columns. */
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(colnames = allocVector(STRSXP, 2));
SET_STRING_ELT(colnames, 0, mkChar("from"));
SET_STRING_ELT(colnames, 1, mkChar("to"));
SET_VECTOR_ELT(dimnames, 1, colnames);
/* names for the cached information. */
PROTECT(elnames = allocVector(STRSXP, 4));
SET_STRING_ELT(elnames, 0, mkChar("mb"));
SET_STRING_ELT(elnames, 1, mkChar("nbr"));
SET_STRING_ELT(elnames, 2, mkChar("parents"));
SET_STRING_ELT(elnames, 3, mkChar("children"));
/* allocate and initialize the arc set. */
PROTECT(arcs = allocMatrix(STRSXP, 0, 2));
setAttrib(arcs, R_DimNamesSymbol, dimnames);
/* allocate and initialize nodes' cached information. */
PROTECT(base2 = allocVector(STRSXP, 0));
PROTECT(base = allocVector(VECSXP, 4));
setAttrib(base, R_NamesSymbol, elnames);
PROTECT(cached = allocVector(VECSXP, nnodes));
setAttrib(cached, R_NamesSymbol, nodes);
for (i = 0; i < 4; i++)
SET_VECTOR_ELT(base, i, base2);
for (i = 0; i < nnodes; i++)
SET_VECTOR_ELT(cached, i, base);
/* generate the "bn" structure. */
PROTECT(res = bn_base_structure(nodes, args, arcs, cached, 0, "none", "empty"));
/* return a list if more than one bn is generated. */
if (*n > 1) {
PROTECT(list = allocVector(VECSXP, *n));
for (i = 0; i < *n; i++)
SET_VECTOR_ELT(list, i, res);
UNPROTECT(10);
return list;
}/*THEN*/
else {
UNPROTECT(9);
return res;
}/*ELSE*/
}/*EMPTY_GRAPH*/
/* This function calls emcluster() in "src/emcluster.c" and is called by
emcluster() using .Call() in "R/fcn_emcluster.r".
Input:
R_x: SEXP[R_n * R_p], data matrix of R_n*R_p.
R_n: SEXP[1], number of observations.
R_p: SEXP[1], number of dimersions.
R_nclass: SEXP[1], number of classes. # k
R_p_LTSigma: SEXP[1], dimersion of LTSigma, p * (p + 1) / 2.
R_pi: SEXP[R_nclass], proportions of classes.
R_Mu: SEXP[R_nclass, R_p], means of MVNs.
R_LTSigma: SEXP[R_nclass, R_p * (R_p + 1) / 2], lower triangular sigma
matrices.
R_em_iter: SEXP[1], max iterations for emclust(), 1000 by default.
R_em_eps: SEXP[1], tolerance for emclust(), 1e-4 by default.
Output:
ret: a list contains
pi: SEXP[R_nclass], proportions of classes.
Mu: SEXP[R_nclass, R_p], means of MVNs.
LTSigma: SEXP[R_nclass, R_p * (R_p + 1) / 2], lower triangular sigma
matrices.
llhdval: SEXP[1], log likelihood value.
*/
SEXP R_emcluster(SEXP R_x, SEXP R_n, SEXP R_p, SEXP R_nclass, SEXP R_p_LTSigma,
SEXP R_pi, SEXP R_Mu, SEXP R_LTSigma, SEXP R_em_iter, SEXP R_em_eps){
/* Declare variables for calling C. */
double **C_x, *C_pi, **C_Mu, **C_LTSigma, *C_llhdval, *C_em_eps;
int *C_n, *C_p, *C_nclass, *C_p_LTSigma, *C_em_iter;
/* Declare variables for R's returning. */
SEXP pi, Mu, LTSigma, llhdval, ret, ret_names;
/* Declare variables for processing. */
double *tmp_1, *tmp_2;
int i, j, tl;
char *names[4] = {"pi", "Mu", "LTSigma", "llhdval"};
/* Set initial values. */
C_n = INTEGER(R_n);
C_p = INTEGER(R_p);
C_nclass = INTEGER(R_nclass);
C_p_LTSigma = INTEGER(R_p_LTSigma);
/* Allocate and protate storages. */
PROTECT(pi = allocVector(REALSXP, *C_nclass));
PROTECT(Mu = allocVector(REALSXP, *C_nclass * *C_p));
PROTECT(LTSigma = allocVector(REALSXP, *C_nclass * *C_p_LTSigma));
PROTECT(llhdval = allocVector(REALSXP, 1));
PROTECT(ret = allocVector(VECSXP, 4));
PROTECT(ret_names = allocVector(STRSXP, 4));
i = 0;
SET_VECTOR_ELT(ret, i++, pi);
SET_VECTOR_ELT(ret, i++, Mu);
SET_VECTOR_ELT(ret, i++, LTSigma);
SET_VECTOR_ELT(ret, i++, llhdval);
for(i = 0; i < 4; i++){
SET_STRING_ELT(ret_names, i, mkChar(names[i]));
}
setAttrib(ret, R_NamesSymbol, ret_names);
/* Assign data. */
C_x = allocate_double_array(*C_n);
C_Mu = allocate_double_array(*C_nclass);
C_LTSigma = allocate_double_array(*C_nclass);
tmp_1 = REAL(R_x);
for(i = 0; i < *C_n; i++){
C_x[i] = tmp_1;
tmp_1 += *C_p;
}
tmp_1 = REAL(Mu);
tmp_2 = REAL(LTSigma);
for(i = 0; i < *C_nclass; i++){
C_Mu[i] = tmp_1;
C_LTSigma[i] = tmp_2;
tmp_1 += *C_p;
tmp_2 += *C_p_LTSigma;
}
C_pi = REAL(pi);
C_llhdval = REAL(llhdval);
C_em_iter = INTEGER(R_em_iter);
C_em_eps = REAL(R_em_eps);
/* Copy R objects to input oebjects for C. */
tmp_1 = REAL(R_pi);
for(i = 0; i < *C_nclass; i++){
C_pi[i] = *(tmp_1 + i);
}
tl = 0;
tmp_1 = REAL(R_Mu);
for(i = 0; i < *C_nclass; i++){
for(j = 0; j < *C_p; j++){
C_Mu[i][j] = *(tmp_1 + tl++);
}
}
tl = 0;
tmp_1 = REAL(R_LTSigma);
for(i = 0; i < *C_nclass; i++){
for(j = 0; j < *C_p_LTSigma; j++){
C_LTSigma[i][j] = *(tmp_1 + tl++);
}
}
/* Compute. */
emcluster(*C_n, *C_p, *C_nclass, C_pi, C_x, C_Mu, C_LTSigma,
*C_em_iter, *C_em_eps, C_llhdval);
/* Free memory and release protectation. */
free(C_x);
free(C_Mu);
free(C_LTSigma);
UNPROTECT(6);
return(ret);
} /* End of R_emcluster(). */
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 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;
}
// Create the OpenGL or OpenGL ES context
//
GLFWbool _glfwCreateContextWGL(_GLFWwindow* window,
const _GLFWctxconfig* ctxconfig,
const _GLFWfbconfig* fbconfig)
{
int attribs[40];
int pixelFormat;
PIXELFORMATDESCRIPTOR pfd;
HGLRC share = NULL;
if (ctxconfig->share)
share = ctxconfig->share->context.wgl.handle;
window->context.wgl.dc = GetDC(window->win32.handle);
if (!window->context.wgl.dc)
{
_glfwInputError(GLFW_PLATFORM_ERROR,
"WGL: Failed to retrieve DC for window");
return GLFW_FALSE;
}
pixelFormat = choosePixelFormat(window, ctxconfig, fbconfig);
if (!pixelFormat)
return GLFW_FALSE;
if (!DescribePixelFormat(window->context.wgl.dc,
pixelFormat, sizeof(pfd), &pfd))
{
_glfwInputErrorWin32(GLFW_PLATFORM_ERROR,
"WGL: Failed to retrieve PFD for selected pixel format");
return GLFW_FALSE;
}
if (!SetPixelFormat(window->context.wgl.dc, pixelFormat, &pfd))
{
_glfwInputErrorWin32(GLFW_PLATFORM_ERROR,
"WGL: Failed to set selected pixel format");
return GLFW_FALSE;
}
if (ctxconfig->client == GLFW_OPENGL_API)
{
if (ctxconfig->forward)
{
if (!_glfw.wgl.ARB_create_context)
{
_glfwInputError(GLFW_VERSION_UNAVAILABLE,
"WGL: A forward compatible OpenGL context requested but WGL_ARB_create_context is unavailable");
return GLFW_FALSE;
}
}
if (ctxconfig->profile)
{
if (!_glfw.wgl.ARB_create_context_profile)
{
_glfwInputError(GLFW_VERSION_UNAVAILABLE,
"WGL: OpenGL profile requested but WGL_ARB_create_context_profile is unavailable");
return GLFW_FALSE;
}
}
}
else
{
if (!_glfw.wgl.ARB_create_context ||
!_glfw.wgl.ARB_create_context_profile ||
!_glfw.wgl.EXT_create_context_es2_profile)
{
_glfwInputError(GLFW_API_UNAVAILABLE,
"WGL: OpenGL ES requested but WGL_ARB_create_context_es2_profile is unavailable");
return GLFW_FALSE;
}
}
if (_glfw.wgl.ARB_create_context)
{
int index = 0, mask = 0, flags = 0;
if (ctxconfig->client == GLFW_OPENGL_API)
{
if (ctxconfig->forward)
flags |= WGL_CONTEXT_FORWARD_COMPATIBLE_BIT_ARB;
if (ctxconfig->profile == GLFW_OPENGL_CORE_PROFILE)
mask |= WGL_CONTEXT_CORE_PROFILE_BIT_ARB;
else if (ctxconfig->profile == GLFW_OPENGL_COMPAT_PROFILE)
mask |= WGL_CONTEXT_COMPATIBILITY_PROFILE_BIT_ARB;
}
else
mask |= WGL_CONTEXT_ES2_PROFILE_BIT_EXT;
if (ctxconfig->debug)
flags |= WGL_CONTEXT_DEBUG_BIT_ARB;
if (ctxconfig->robustness)
{
if (_glfw.wgl.ARB_create_context_robustness)
{
if (ctxconfig->robustness == GLFW_NO_RESET_NOTIFICATION)
{
setAttrib(WGL_CONTEXT_RESET_NOTIFICATION_STRATEGY_ARB,
WGL_NO_RESET_NOTIFICATION_ARB);
}
else if (ctxconfig->robustness == GLFW_LOSE_CONTEXT_ON_RESET)
{
setAttrib(WGL_CONTEXT_RESET_NOTIFICATION_STRATEGY_ARB,
WGL_LOSE_CONTEXT_ON_RESET_ARB);
}
flags |= WGL_CONTEXT_ROBUST_ACCESS_BIT_ARB;
}
}
if (ctxconfig->release)
{
if (_glfw.wgl.ARB_context_flush_control)
{
if (ctxconfig->release == GLFW_RELEASE_BEHAVIOR_NONE)
{
setAttrib(WGL_CONTEXT_RELEASE_BEHAVIOR_ARB,
WGL_CONTEXT_RELEASE_BEHAVIOR_NONE_ARB);
}
else if (ctxconfig->release == GLFW_RELEASE_BEHAVIOR_FLUSH)
{
setAttrib(WGL_CONTEXT_RELEASE_BEHAVIOR_ARB,
WGL_CONTEXT_RELEASE_BEHAVIOR_FLUSH_ARB);
}
}
}
if (ctxconfig->noerror)
{
if (_glfw.wgl.ARB_create_context_no_error)
setAttrib(WGL_CONTEXT_OPENGL_NO_ERROR_ARB, GLFW_TRUE);
}
// NOTE: Only request an explicitly versioned context when necessary, as
// explicitly requesting version 1.0 does not always return the
// highest version supported by the driver
if (ctxconfig->major != 1 || ctxconfig->minor != 0)
{
setAttrib(WGL_CONTEXT_MAJOR_VERSION_ARB, ctxconfig->major);
setAttrib(WGL_CONTEXT_MINOR_VERSION_ARB, ctxconfig->minor);
}
if (flags)
setAttrib(WGL_CONTEXT_FLAGS_ARB, flags);
if (mask)
setAttrib(WGL_CONTEXT_PROFILE_MASK_ARB, mask);
setAttrib(0, 0);
window->context.wgl.handle =
_glfw.wgl.CreateContextAttribsARB(window->context.wgl.dc,
share, attribs);
if (!window->context.wgl.handle)
{
const DWORD error = GetLastError();
if (error == (0xc0070000 | ERROR_INVALID_VERSION_ARB))
{
if (ctxconfig->client == GLFW_OPENGL_API)
{
_glfwInputError(GLFW_VERSION_UNAVAILABLE,
"WGL: Driver does not support OpenGL version %i.%i",
ctxconfig->major,
ctxconfig->minor);
}
else
{
_glfwInputError(GLFW_VERSION_UNAVAILABLE,
"WGL: Driver does not support OpenGL ES version %i.%i",
ctxconfig->major,
ctxconfig->minor);
}
}
else if (error == (0xc0070000 | ERROR_INVALID_PROFILE_ARB))
{
_glfwInputError(GLFW_VERSION_UNAVAILABLE,
"WGL: Driver does not support the requested OpenGL profile");
}
else if (error == (0xc0070000 | ERROR_INCOMPATIBLE_DEVICE_CONTEXTS_ARB))
{
_glfwInputError(GLFW_INVALID_VALUE,
"WGL: The share context is not compatible with the requested context");
}
else
{
if (ctxconfig->client == GLFW_OPENGL_API)
{
_glfwInputError(GLFW_VERSION_UNAVAILABLE,
"WGL: Failed to create OpenGL context");
}
else
{
_glfwInputError(GLFW_VERSION_UNAVAILABLE,
"WGL: Failed to create OpenGL ES context");
}
}
return GLFW_FALSE;
}
}
else
{
window->context.wgl.handle = wglCreateContext(window->context.wgl.dc);
if (!window->context.wgl.handle)
{
_glfwInputErrorWin32(GLFW_VERSION_UNAVAILABLE,
"WGL: Failed to create OpenGL context");
return GLFW_FALSE;
}
if (share)
{
if (!wglShareLists(share, window->context.wgl.handle))
{
_glfwInputErrorWin32(GLFW_PLATFORM_ERROR,
"WGL: Failed to enable sharing with specified OpenGL context");
return GLFW_FALSE;
}
}
}
window->context.makeCurrent = makeContextCurrentWGL;
window->context.swapBuffers = swapBuffersWGL;
window->context.swapInterval = swapIntervalWGL;
window->context.extensionSupported = extensionSupportedWGL;
window->context.getProcAddress = getProcAddressWGL;
window->context.destroy = destroyContextWGL;
return GLFW_TRUE;
}
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;
}
ymbool CYmMusic::ymDecode(void)
{
ymu8 *pUD;
ymu8 *ptr;
ymint skip;
ymint i;
ymu32 sampleSize;
yms32 tmp;
ymu32 id;
id = ReadBigEndian32((unsigned char*)pBigMalloc);
switch (id)
{
case 'YM2!': // MADMAX specific.
songType = YM_V2;
nbFrame = (fileSize-4)/14;
loopFrame = 0;
ymChip.setClock(ATARI_CLOCK);
setPlayerRate(50);
pDataStream = pBigMalloc+4;
streamInc = 14;
nbDrum = 0;
setAttrib(A_STREAMINTERLEAVED|A_TIMECONTROL);
pSongName = mstrdup("Unknown");
pSongAuthor = mstrdup("Unkonwn");
pSongComment = mstrdup("Converted by Leonard.");
pSongType = mstrdup("YM 2");
pSongPlayer = mstrdup("YM-Chip driver.");
break;
case 'YM3!': // Standart YM-Atari format.
songType = YM_V3;
nbFrame = (fileSize-4)/14;
loopFrame = 0;
ymChip.setClock(ATARI_CLOCK);
setPlayerRate(50);
pDataStream = pBigMalloc+4;
streamInc = 14;
nbDrum = 0;
setAttrib(A_STREAMINTERLEAVED|A_TIMECONTROL);
pSongName = mstrdup("Unknown");
pSongAuthor = mstrdup("Unkonwn");
pSongComment = mstrdup("");
pSongType = mstrdup("YM 3");
pSongPlayer = mstrdup("YM-Chip driver.");
break;
case 'YM3b': // Standart YM-Atari format + Loop info.
pUD = (ymu8*)(pBigMalloc+fileSize-4);
songType = YM_V3;
nbFrame = (fileSize-4)/14;
loopFrame = ReadLittleEndian32(pUD);
ymChip.setClock(ATARI_CLOCK);
setPlayerRate(50);
pDataStream = pBigMalloc+4;
streamInc = 14;
nbDrum = 0;
setAttrib(A_STREAMINTERLEAVED|A_TIMECONTROL);
pSongName = mstrdup("Unknown");
pSongAuthor = mstrdup("Unkonwn");
pSongComment = mstrdup("");
pSongType = mstrdup("YM 3b (loop)");
pSongPlayer = mstrdup("YM-Chip driver.");
break;
case 'YM4!': // Extended ATARI format.
setLastError("No more YM4! support. Use YM5! format.");
return YMFALSE;
break;
case 'YM5!': // Extended YM2149 format, all machines.
case 'YM6!': // Extended YM2149 format, all machines.
if (strncmp((const char*)(pBigMalloc+4),"LeOnArD!",8))
{
setLastError("Not a valid YM format !");
return YMFALSE;
}
ptr = pBigMalloc+12;
nbFrame = readMotorolaDword(&ptr);
setAttrib(readMotorolaDword(&ptr));
nbDrum = readMotorolaWord(&ptr);
ymChip.setClock(readMotorolaDword(&ptr));
setPlayerRate(readMotorolaWord(&ptr));
loopFrame = readMotorolaDword(&ptr);
skip = readMotorolaWord(&ptr);
ptr += skip;
if (nbDrum>0)
{
pDrumTab=(digiDrum_t*)malloc(nbDrum*sizeof(digiDrum_t));
for (i=0;i<nbDrum;i++)
{
pDrumTab[i].size = readMotorolaDword(&ptr);
if (pDrumTab[i].size)
{
pDrumTab[i].pData = (ymu8*)malloc(pDrumTab[i].size);
memcpy(pDrumTab[i].pData,ptr,pDrumTab[i].size);
if (attrib&A_DRUM4BITS)
{
ymu32 j;
ymu8 *pw = pDrumTab[i].pData;
for (j=0;j<pDrumTab[i].size;j++)
{
*pw++ = ymVolumeTable[(*pw)&15]>>7;
}
}
ptr += pDrumTab[i].size;
}
else
{
/* unconditional independence tests. */
SEXP utest(SEXP x, SEXP y, SEXP data, SEXP test, SEXP B, SEXP alpha,
SEXP learning) {
int ntests = length(x), nobs = 0;
double *pvalue = NULL, statistic = 0, df = NA_REAL;
const char *t = CHAR(STRING_ELT(test, 0));
test_e test_type = test_label(t);
SEXP xx, yy, result;
/* allocate the return value, which has the same length as x. */
PROTECT(result = allocVector(REALSXP, ntests));
setAttrib(result, R_NamesSymbol, x);
pvalue = REAL(result);
/* set all elements to zero. */
memset(pvalue, '\0', ntests * sizeof(double));
/* extract the variables from the data. */
PROTECT(xx = c_dataframe_column(data, x, FALSE, FALSE));
PROTECT(yy = c_dataframe_column(data, y, TRUE, FALSE));
nobs = length(yy);
if (IS_DISCRETE_ASYMPTOTIC_TEST(test_type)) {
/* parametric tests for discrete variables. */
statistic = ut_discrete(xx, yy, nobs, ntests, pvalue, &df, test_type);
}/*THEN*/
else if ((test_type == COR) || (test_type == ZF) || (test_type == MI_G) ||
(test_type == MI_G_SH)) {
/* parametric tests for Gaussian variables. */
statistic = ut_gaustests(xx, yy, nobs, ntests, pvalue, &df, test_type);
}/*THEN*/
else if (test_type == MI_CG) {
/* conditional linear Gaussian mutual information test. */
statistic = ut_micg(xx, yy, nobs, ntests, pvalue, &df);
}/*THEN*/
else if (IS_DISCRETE_PERMUTATION_TEST(test_type)) {
statistic = ut_dperm(xx, yy, nobs, ntests, pvalue, &df, test_type, INT(B),
IS_SMC(test_type) ? NUM(alpha) : 1);
}/*THEN*/
else if (IS_CONTINUOUS_PERMUTATION_TEST(test_type)) {
statistic = ut_gperm(xx, yy, nobs, ntests, pvalue, test_type, INT(B),
IS_SMC(test_type) ? NUM(alpha) : 1);
}/*THEN*/
UNPROTECT(3);
/* catch-all for unknown tests (after deallocating memory.) */
if (test_type == ENOTEST)
error("unknown test statistic '%s'.", t);
/* increase the test counter. */
test_counter += ntests;
if (isTRUE(learning))
return result;
else
return c_create_htest(statistic, test, pvalue[ntests - 1], df, B);
}/*UTEST*/
/*
Susceptible-Infectious-Removed MCMC analysis:
. Exponentially distributed infectiousness periods
*/
SEXP expMH_SIR(SEXP N, SEXP removalTimes, SEXP otherParameters, SEXP priorValues,
SEXP initialValues, SEXP bayesReps, SEXP bayesStart, SEXP bayesThin, SEXP bayesOut){
/* Declarations */
int ii, jj, kk, ll, nInfected, nRemoved, nProtected=0, initialInfected;
SEXP infRateSIR, remRateSIR, logLikelihood;/*, timeInfected, timeDim, initialInf ; */
SEXP parameters, infectionTimes, candidateTimes, infectedBeforeDay;
SEXP allTimes, indicator, SS, II;
double infRate, remRate, oldLkhood, newLkhood, minimumLikelyInfectionTime; /* starting values */
double infRatePrior[2], remRatePrior[2], thetaprior; /* priors values */
double sumSI, sumDurationInfectious, likelihood,logR;
int acceptRate=0, consistent=0, verbose, missingInfectionTimes;
SEXP retParameters, parNames, acceptanceRate;
SEXP infTimes;
/* Code */
GetRNGstate(); /* should be before a call to a random number generator */
initialInfected = INTEGER(getListElement(otherParameters, "initialInfected"))[0];
verbose = INTEGER(getListElement(otherParameters, "verbose"))[0];
missingInfectionTimes = INTEGER(getListElement(otherParameters, "missingInfectionTimes"))[0];
PROTECT(N = AS_INTEGER(N));
++nProtected;
PROTECT(removalTimes = AS_NUMERIC(removalTimes));
++nProtected;
/* priors and starting values */
PROTECT(priorValues = AS_LIST(priorValues));
++nProtected;
PROTECT(initialValues = AS_LIST(initialValues));
++nProtected;
nRemoved = LENGTH(removalTimes); /* number of individuals removed */
/* bayes replications, thin, etc */
PROTECT(bayesReps = AS_INTEGER(bayesReps));
++nProtected;
PROTECT(bayesStart = AS_INTEGER(bayesStart));
++nProtected;
PROTECT(bayesThin = AS_INTEGER(bayesThin));
++nProtected;
PROTECT(bayesOut = AS_INTEGER(bayesOut));
++nProtected;
PROTECT(infRateSIR = allocVector(REALSXP, INTEGER(bayesOut)[0]));
++nProtected;
PROTECT(remRateSIR = allocVector(REALSXP, INTEGER(bayesOut)[0]));
++nProtected;
PROTECT(logLikelihood = allocVector(REALSXP, INTEGER(bayesOut)[0]));
++nProtected;
/*
PROTECT(timeInfected = allocVector(REALSXP, nRemoved * INTEGER(bayesOut)[0]));
++nProtected;
PROTECT(timeDim = allocVector(INTSXP, 2));
++nProtected;
INTEGER(timeDim)[0] = nRemoved;
INTEGER(timeDim)[1] = INTEGER(bayesOut)[0];
setAttrib(timeInfected, R_DimSymbol, timeDim);
PROTECT(initialInf = allocVector(REALSXP, INTEGER(bayesOut)[0]));
++nProtected;
*/
PROTECT(parameters = allocVector(REALSXP,2));
++nProtected;
PROTECT(infectionTimes = allocVector(REALSXP,nRemoved));
++nProtected;
PROTECT(candidateTimes = allocVector(REALSXP,nRemoved));
++nProtected;
PROTECT(infectedBeforeDay = allocVector(REALSXP,nRemoved));
++nProtected;
PROTECT(infTimes = allocVector(REALSXP,nRemoved));
++nProtected;
for(jj = 0; jj < nRemoved; ++jj){
REAL(infectionTimes)[jj] = REAL(getListElement(initialValues, "infectionTimes"))[jj];
REAL(candidateTimes)[jj] = REAL(infectionTimes)[jj];
REAL(infectedBeforeDay)[jj] = REAL(getListElement(otherParameters, "infectedBeforeDay"))[jj];
REAL(infTimes)[jj] = 0;
}
nInfected = LENGTH(infectionTimes);
PROTECT(allTimes = allocVector(REALSXP,nRemoved+nInfected));
++nProtected;
PROTECT(indicator = allocVector(INTSXP,nRemoved+nInfected));
++nProtected;
PROTECT(SS = allocVector(INTSXP,nRemoved+nInfected+1));
++nProtected;
PROTECT(II = allocVector(INTSXP,nRemoved+nInfected+1));
++nProtected;
/* working variables */
infRate = REAL(getListElement(initialValues, "infectionRate"))[0];
remRate = REAL(getListElement(initialValues, "removalRate"))[0];
minimumLikelyInfectionTime = REAL(getListElement(otherParameters, "minimumLikelyInfectionTime"))[0];
for(ii = 0; ii < 2; ++ii){
infRatePrior[ii] = REAL(getListElement(priorValues, "infectionRate"))[ii];
remRatePrior[ii] = REAL(getListElement(priorValues, "removalRate"))[ii];
}
thetaprior = REAL(getListElement(priorValues, "theta"))[0];
REAL(parameters)[0] = infRate;
REAL(parameters)[1] = remRate;
expLikelihood_SIR(REAL(parameters),REAL(infectionTimes),
REAL(removalTimes), &INTEGER(N)[0], &nInfected, &nRemoved,
&sumSI, &sumDurationInfectious, &likelihood,
REAL(allTimes),INTEGER(indicator),INTEGER(SS),INTEGER(II));
oldLkhood = likelihood;
for(ii = 1; ii <= INTEGER(bayesReps)[0]; ++ii){
infRate = rgamma(nInfected-1+infRatePrior[0],1/(sumSI+infRatePrior[1])); /* update infRate */
remRate = rgamma(nRemoved+remRatePrior[0],1/(sumDurationInfectious+remRatePrior[1]));/*remRate */
/*Rprintf("SI = %f : I = %f\n",sumSI,sumDurationInfectious);*/
REAL(parameters)[0] = infRate;
REAL(parameters)[1] = remRate;
if(missingInfectionTimes){
expLikelihood_SIR(REAL(parameters),REAL(infectionTimes),
REAL(removalTimes), &INTEGER(N)[0], &nInfected, &nRemoved,
&sumSI, &sumDurationInfectious, &likelihood,
REAL(allTimes),INTEGER(indicator),INTEGER(SS),INTEGER(II));
oldLkhood = likelihood;
kk = ceil(unif_rand()*(nRemoved-1)); /* initial infection time excluded */
consistent=0;
if(kk == nRemoved-1){
REAL(candidateTimes)[kk] =
runif(REAL(infectionTimes)[kk-1], REAL(infectedBeforeDay)[kk]);}
else if((REAL(infectionTimes)[kk+1] > REAL(infectedBeforeDay)[kk])){
REAL(candidateTimes)[kk] =
runif(REAL(infectionTimes)[kk-1], REAL(infectedBeforeDay)[kk]);}
else{REAL(candidateTimes)[kk] =
runif(REAL(infectionTimes)[kk-1], REAL(infectionTimes)[kk+1]);}
expLikelihood_SIR(REAL(parameters),REAL(candidateTimes),
REAL(removalTimes), &INTEGER(N)[0], &nInfected, &nRemoved,
&sumSI, &sumDurationInfectious, &likelihood,
REAL(allTimes),INTEGER(indicator),INTEGER(SS),INTEGER(II));
newLkhood = likelihood;
logR = (newLkhood-oldLkhood);
if(log(unif_rand()) <= logR){
REAL(infectionTimes)[kk] = REAL(candidateTimes)[kk];
++acceptRate;
}
REAL(candidateTimes)[kk] = REAL(infectionTimes)[kk];/* update candidate times */
REAL(infectionTimes)[0] = REAL(infectionTimes)[1]
-rexp(1/(infRate*INTEGER(N)[0]+remRate+thetaprior));
REAL(candidateTimes)[0] = REAL(infectionTimes)[0];
}
expLikelihood_SIR(REAL(parameters),REAL(infectionTimes),
REAL(removalTimes), &INTEGER(N)[0], &nInfected, &nRemoved,
&sumSI, &sumDurationInfectious, &likelihood,
REAL(allTimes),INTEGER(indicator),INTEGER(SS),INTEGER(II));
oldLkhood = likelihood;
kk = ceil(INTEGER(bayesReps)[0]/100);
ll = ceil(INTEGER(bayesReps)[0]/ 10);
if(verbose == 1){
if((ii % kk) == 0){Rprintf(".");}
if((ii % ll) == 0){Rprintf(" %d\n",ii);}
}
if((ii >= (INTEGER(bayesStart)[0])) &&
((ii-INTEGER(bayesStart)[0]) % INTEGER(bayesThin)[0] == 0)){
ll = (ii - (INTEGER(bayesStart)[0]))/INTEGER(bayesThin)[0];
/* REAL(initialInf)[ll] = REAL(infectionTimes)[0]; */
REAL(logLikelihood)[ll] = likelihood;
REAL(infRateSIR)[ll] = infRate;
REAL(remRateSIR)[ll] = remRate;
for(jj = 0; jj < nRemoved; ++jj){
REAL(infTimes)[jj] += REAL(infectionTimes)[jj];
}
/*
for(jj = 0; jj < nRemoved; ++jj){
REAL(timeInfected)[(nRemoved*ll+jj)] = REAL(infectionTimes)[jj];
}
*/
}
}
PutRNGstate(); /* after using random number generators. */
/* Print infection times and removal times at last iteration */
for(jj = 0; jj < nRemoved; ++jj){
REAL(infTimes)[jj] = REAL(infTimes)[jj]/INTEGER(bayesOut)[0];
}
if(verbose){
for(jj = 0; jj < nRemoved; ++jj){
Rprintf("%2d %8.4f %2.0f\n",jj,
REAL(infTimes)[jj],REAL(removalTimes)[jj]);
}
}
PROTECT(retParameters = NEW_LIST(5));
++nProtected;
PROTECT(acceptanceRate = allocVector(INTSXP,1));
++nProtected;
INTEGER(acceptanceRate)[0] = acceptRate;
PROTECT(parNames = allocVector(STRSXP,5));
++nProtected;
SET_STRING_ELT(parNames, 0, mkChar("logLikelihood"));
SET_STRING_ELT(parNames, 1, mkChar("infRateSIR"));
SET_STRING_ELT(parNames, 2, mkChar("remRateSIR"));
SET_STRING_ELT(parNames, 3, mkChar("infectionTimes"));
SET_STRING_ELT(parNames, 4, mkChar("acceptanceRate"));
setAttrib(retParameters, R_NamesSymbol,parNames);
SET_ELEMENT(retParameters, 0, logLikelihood);
SET_ELEMENT(retParameters, 1, infRateSIR);
SET_ELEMENT(retParameters, 2, remRateSIR);
SET_ELEMENT(retParameters, 3, infTimes);
SET_ELEMENT(retParameters, 4, acceptanceRate);
/*
SET_ELEMENT(retParameters, 3, initialInf);
SET_ELEMENT(retParameters, 4, timeInfected);
*/
UNPROTECT(nProtected);
return(retParameters);
}
/* --- .Call ENTRY POINT --- */
SEXP BWGFile_query(SEXP r_filename, SEXP r_ranges, SEXP r_return_score) {
pushRHandlers();
struct bbiFile * file = bigWigFileOpen((char *)CHAR(asChar(r_filename)));
SEXP chromNames = getAttrib(r_ranges, R_NamesSymbol);
int nchroms = length(r_ranges);
SEXP rangesList, rangesListEls, dataFrameList, dataFrameListEls, ans;
bool returnScore = asLogical(r_return_score);
const char *var_names[] = { "score", "" };
struct lm *lm = lmInit(0);
struct bbiInterval *hits = NULL;
PROTECT(rangesListEls = allocVector(VECSXP, nchroms));
setAttrib(rangesListEls, R_NamesSymbol, chromNames);
PROTECT(dataFrameListEls = allocVector(VECSXP, nchroms));
setAttrib(dataFrameListEls, R_NamesSymbol, chromNames);
for (int i = 0; i < length(r_ranges); i++) {
SEXP localRanges = VECTOR_ELT(r_ranges, i);
int nranges = get_IRanges_length(localRanges);
int *start = INTEGER(get_IRanges_start(localRanges));
int *width = INTEGER(get_IRanges_width(localRanges));
for (int j = 0; j < nranges; j++) {
struct bbiInterval *queryHits =
bigWigIntervalQuery(file, (char *)CHAR(STRING_ELT(chromNames, i)),
start[j] - 1, start[j] - 1 + width[j], lm);
slReverse(&queryHits);
hits = slCat(queryHits, hits);
}
int nhits = slCount(hits);
SEXP ans_start, ans_width, ans_score, ans_score_l;
PROTECT(ans_start = allocVector(INTSXP, nhits));
PROTECT(ans_width = allocVector(INTSXP, nhits));
if (returnScore) {
PROTECT(ans_score_l = mkNamed(VECSXP, var_names));
ans_score = allocVector(REALSXP, nhits);
SET_VECTOR_ELT(ans_score_l, 0, ans_score);
} else PROTECT(ans_score_l = mkNamed(VECSXP, var_names + 1));
slReverse(&hits);
for (int j = 0; j < nhits; j++, hits = hits->next) {
INTEGER(ans_start)[j] = hits->start + 1;
INTEGER(ans_width)[j] = hits->end - hits->start;
if (returnScore)
REAL(ans_score)[j] = hits->val;
}
SET_VECTOR_ELT(rangesListEls, i,
new_IRanges("IRanges", ans_start, ans_width, R_NilValue));
SET_VECTOR_ELT(dataFrameListEls, i,
new_DataFrame("DataFrame", ans_score_l, R_NilValue,
ScalarInteger(nhits)));
UNPROTECT(3);
}
bbiFileClose(&file);
PROTECT(dataFrameList =
new_SimpleList("SimpleSplitDataFrameList", dataFrameListEls));
PROTECT(rangesList = new_SimpleList("SimpleRangesList", rangesListEls));
ans = new_RangedData("RangedData", rangesList, dataFrameList);
UNPROTECT(4);
lmCleanup(&lm);
popRHandlers();
return ans;
}
SEXP buildHistograms(SEXP R_observations, SEXP R_responses,
SEXP R_forest,
SEXP R_active_nodes, SEXP R_random_features,
SEXP histograms)
{
hpdRFforest * forest = (hpdRFforest *) R_ExternalPtrAddr(R_forest);
int* active_nodes = INTEGER(R_active_nodes);
int* bin_num = forest->bin_num;
int class_num = forest->response_cardinality == NA_INTEGER ?
2: forest->response_cardinality;
int* features_categorical = forest->features_cardinality;
bool response_categorical = forest->response_cardinality != NA_INTEGER;
int single_hist_size = 0;
for(int i = 0; i < forest->nfeature; i++)
if(single_hist_size < bin_num[i])
single_hist_size = bin_num[i];
single_hist_size *= class_num;
int* node_observations;
int node_observations_num;
double* weight_observations;
int* node_features;
bool realloc_histogram = false;
hpdRFnode *node_curr;
if(histograms == R_NilValue ||
length(histograms) < length(R_active_nodes))
{
SEXP temp_histograms = histograms;
PROTECT(histograms = allocVector(VECSXP, length(R_active_nodes)));
for(int i = 0; i < length(temp_histograms); i++)
SET_VECTOR_ELT(histograms,i,VECTOR_ELT(temp_histograms,i));
for(int i = length(temp_histograms); i < length(histograms); i++)
{
SEXP node_histogram;
PROTECT(node_histogram=allocVector(VECSXP,forest->features_num));
SET_VECTOR_ELT(histograms,i,node_histogram);
for(int j = 0; j < forest->features_num; j++)
{
SEXP single_hist;
PROTECT(single_hist = allocVector(REALSXP,single_hist_size));
SET_VECTOR_ELT(node_histogram,j,single_hist);
setAttrib(single_hist,install("feature"),ScalarInteger(-1));
UNPROTECT(1);
}
UNPROTECT(1);
}
realloc_histogram = true;
}
for(int i = 0; i < length(R_active_nodes); i++)
{
int active_node = active_nodes[i]-1;
SEXP random_node_features = VECTOR_ELT(R_random_features,i);
node_features = INTEGER(random_node_features);
node_curr = forest->leaf_nodes[active_node];
weight_observations = node_curr->additional_info->weights;
node_observations = node_curr->additional_info->indices;
node_observations_num = node_curr->additional_info->num_obs;
SEXP node_histograms;
node_histograms = VECTOR_ELT(histograms,i);
setAttrib(node_histograms,install("n"),
ScalarInteger(node_curr->additional_info->num_obs));
for(int feature = 0; feature < length(random_node_features); feature++)
{
int featureIndex = node_features[feature]-1;
SEXP histogram_curr;
int histogram_size = class_num*bin_num[featureIndex] ;
histogram_curr = VECTOR_ELT(node_histograms,feature);
memset(REAL(histogram_curr),0,sizeof(double)*histogram_size);
#define buildSingleHistogram(x) buildHistogram<x>(VECTOR_ELT(R_observations,featureIndex), \
R_responses,weight_observations, \
node_observations, node_observations_num, \
bin_num[featureIndex], class_num, \
features_categorical[featureIndex] != NA_INTEGER, \
response_categorical, histogram_curr)
double L2 = 0;
if(TYPEOF(VECTOR_ELT(R_responses,0)) == INTSXP)
L2 = buildSingleHistogram(int);
else if(TYPEOF(VECTOR_ELT(R_responses,0)) == REALSXP)
L2 = buildSingleHistogram(double);
setAttrib(histogram_curr,install("L2"),ScalarReal(L2));
SET_VECTOR_ELT(node_histograms,feature,histogram_curr);
SEXP featureAttrib = getAttrib(histogram_curr,install("feature"));
*INTEGER(featureAttrib) = featureIndex+1;
}
}
static SEXP readRegistryKey(HKEY hkey, int depth, int view)
{
int i, k = 0, size0, *indx;
SEXP ans, nm, ans0, nm0, tmp, sind;
DWORD res, nsubkeys, maxsubkeylen, nval, maxvalnamlen, size;
wchar_t *name;
HKEY sub;
REGSAM acc = KEY_READ;
if (depth <= 0) return mkString("<subkey>");
if(view == 2) acc |= KEY_WOW64_32KEY;
else if(view == 3) acc |= KEY_WOW64_64KEY;
res = RegQueryInfoKey(hkey, NULL, NULL, NULL,
&nsubkeys, &maxsubkeylen, NULL, &nval,
&maxvalnamlen, NULL, NULL, NULL);
if (res != ERROR_SUCCESS)
error("RegQueryInfoKey error code %d: '%s'", (int) res,
formatError(res));
size0 = max(maxsubkeylen, maxvalnamlen) + 1;
name = (wchar_t *) R_alloc(size0, sizeof(wchar_t));
PROTECT(ans = allocVector(VECSXP, nval + nsubkeys));
PROTECT(nm = allocVector(STRSXP, nval+ nsubkeys));
if (nval > 0) {
PROTECT(ans0 = allocVector(VECSXP, nval));
PROTECT(nm0 = allocVector(STRSXP, nval));
for (i = 0; i < nval; i++) {
size = size0;
res = RegEnumValueW(hkey, i, (LPWSTR) name, &size,
NULL, NULL, NULL, NULL);
if (res != ERROR_SUCCESS) break;
SET_VECTOR_ELT(ans0, i, readRegistryKey1(hkey, name));
SET_STRING_ELT(nm0, i, mkCharUcs(name));
}
/* now sort by name */
PROTECT(sind = allocVector(INTSXP, nval)); indx = INTEGER(sind);
for (i = 0; i < nval; i++) indx[i] = i;
orderVector1(indx, nval, nm0, TRUE, FALSE, R_NilValue);
for (i = 0; i < nval; i++, k++) {
SET_VECTOR_ELT(ans, k, VECTOR_ELT(ans0, indx[i]));
if (LENGTH(tmp = STRING_ELT(nm0, indx[i])))
SET_STRING_ELT(nm, k, tmp);
else
SET_STRING_ELT(nm, k, mkChar("(Default)"));
}
UNPROTECT(3);
}
if (nsubkeys > 0) {
PROTECT(ans0 = allocVector(VECSXP, nsubkeys));
PROTECT(nm0 = allocVector(STRSXP, nsubkeys));
for (i = 0; i < nsubkeys; i++) {
size = size0;
res = RegEnumKeyExW(hkey, i, (LPWSTR) name, &size,
NULL, NULL, NULL, NULL);
if (res != ERROR_SUCCESS) break;
res = RegOpenKeyExW(hkey, (LPWSTR) name, 0, acc, &sub);
if (res != ERROR_SUCCESS) break;
SET_VECTOR_ELT(ans0, i, readRegistryKey(sub, depth-1, view));
SET_STRING_ELT(nm0, i, mkCharUcs(name));
RegCloseKey(sub);
}
/* now sort by name */
PROTECT(sind = allocVector(INTSXP, nsubkeys)); indx = INTEGER(sind);
for (i = 0; i < nsubkeys; i++) indx[i] = i;
orderVector1(indx, nsubkeys, nm0, TRUE, FALSE, R_NilValue);
for (i = 0; i < nsubkeys; i++, k++) {
SET_VECTOR_ELT(ans, k, VECTOR_ELT(ans0, indx[i]));
SET_STRING_ELT(nm, k, STRING_ELT(nm0, indx[i]));
}
UNPROTECT(3);
}
setAttrib(ans, R_NamesSymbol, nm);
UNPROTECT(2);
return ans;
}
/* This is for all cases with a single index, including 1D arrays and
matrix indexing of arrays */
static SEXP VectorSubset(SEXP x, SEXP s, SEXP call)
{
R_xlen_t n;
int mode;
R_xlen_t stretch = 1;
SEXP indx, result, attrib, nattrib;
if (s == R_MissingArg) return duplicate(x);
PROTECT(s);
attrib = getAttrib(x, R_DimSymbol);
/* Check to see if we have special matrix subscripting. */
/* If we do, make a real subscript vector and protect it. */
if (isMatrix(s) && isArray(x) && ncols(s) == length(attrib)) {
if (isString(s)) {
s = strmat2intmat(s, GetArrayDimnames(x), call);
UNPROTECT(1);
PROTECT(s);
}
if (isInteger(s) || isReal(s)) {
s = mat2indsub(attrib, s, call);
UNPROTECT(1);
PROTECT(s);
}
}
/* Convert to a vector of integer subscripts */
/* in the range 1:length(x). */
PROTECT(indx = makeSubscript(x, s, &stretch, call));
n = XLENGTH(indx);
/* Allocate the result. */
mode = TYPEOF(x);
/* No protection needed as ExtractSubset does not allocate */
result = allocVector(mode, n);
if (mode == VECSXP || mode == EXPRSXP)
/* we do not duplicate the values when extracting the subset,
so to be conservative mark the result as NAMED = 2 */
SET_NAMED(result, 2);
PROTECT(result = ExtractSubset(x, result, indx, call));
if (result != R_NilValue) {
if (
((attrib = getAttrib(x, R_NamesSymbol)) != R_NilValue) ||
( /* here we might have an array. Use row names if 1D */
isArray(x) && LENGTH(getAttrib(x, R_DimNamesSymbol)) == 1 &&
(attrib = getAttrib(x, R_DimNamesSymbol)) != R_NilValue &&
(attrib = GetRowNames(attrib)) != R_NilValue
)
) {
PROTECT(attrib);
nattrib = allocVector(TYPEOF(attrib), n);
PROTECT(nattrib); /* seems unneeded */
nattrib = ExtractSubset(attrib, nattrib, indx, call);
setAttrib(result, R_NamesSymbol, nattrib);
UNPROTECT(2); /* attrib, nattrib */
}
if ((attrib = getAttrib(x, R_SrcrefSymbol)) != R_NilValue &&
TYPEOF(attrib) == VECSXP) {
nattrib = allocVector(VECSXP, n);
PROTECT(nattrib); /* seems unneeded */
nattrib = ExtractSubset(attrib, nattrib, indx, call);
setAttrib(result, R_SrcrefSymbol, nattrib);
UNPROTECT(1);
}
/* FIXME: this is wrong, because the slots are gone, so result is an invalid object of the S4 class! JMC 3/3/09 */
#ifdef _S4_subsettable
if(IS_S4_OBJECT(x)) { /* e.g. contains = "list" */
setAttrib(result, R_ClassSymbol, getAttrib(x, R_ClassSymbol));
SET_S4_OBJECT(result);
}
#endif
}
UNPROTECT(3);
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);
}
static SEXP MatrixSubset(SEXP x, SEXP s, SEXP call, int drop)
{
SEXP attr, result, sr, sc, dim;
int nr, nc, nrs, ncs;
R_xlen_t i, j, ii, jj, ij, iijj;
nr = nrows(x);
nc = ncols(x);
/* Note that "s" is protected on entry. */
/* The following ensures that pointers remain protected. */
dim = getAttrib(x, R_DimSymbol);
sr = SETCAR(s, int_arraySubscript(0, CAR(s), dim, x, call));
sc = SETCADR(s, int_arraySubscript(1, CADR(s), dim, x, call));
nrs = LENGTH(sr);
ncs = LENGTH(sc);
/* Check this does not overflow: currently only possible on 32-bit */
if ((double)nrs * (double)ncs > R_XLEN_T_MAX)
error(_("dimensions would exceed maximum size of array"));
PROTECT(sr);
PROTECT(sc);
result = allocVector(TYPEOF(x), (R_xlen_t) nrs * (R_xlen_t) ncs);
PROTECT(result);
for (i = 0; i < nrs; i++) {
ii = INTEGER(sr)[i];
if (ii != NA_INTEGER) {
if (ii < 1 || ii > nr)
errorcall(call, R_MSG_subs_o_b);
ii--;
}
for (j = 0; j < ncs; j++) {
jj = INTEGER(sc)[j];
if (jj != NA_INTEGER) {
if (jj < 1 || jj > nc)
errorcall(call, R_MSG_subs_o_b);
jj--;
}
ij = i + j * nrs;
if (ii == NA_INTEGER || jj == NA_INTEGER) {
switch (TYPEOF(x)) {
case LGLSXP:
case INTSXP:
INTEGER(result)[ij] = NA_INTEGER;
break;
case REALSXP:
REAL(result)[ij] = NA_REAL;
break;
case CPLXSXP:
COMPLEX(result)[ij].r = NA_REAL;
COMPLEX(result)[ij].i = NA_REAL;
break;
case STRSXP:
SET_STRING_ELT(result, ij, NA_STRING);
break;
case VECSXP:
SET_VECTOR_ELT(result, ij, R_NilValue);
break;
case RAWSXP:
RAW(result)[ij] = (Rbyte) 0;
break;
default:
errorcall(call, _("matrix subscripting not handled for this type"));
break;
}
}
else {
iijj = ii + jj * nr;
switch (TYPEOF(x)) {
case LGLSXP:
LOGICAL(result)[ij] = LOGICAL(x)[iijj];
break;
case INTSXP:
INTEGER(result)[ij] = INTEGER(x)[iijj];
break;
case REALSXP:
REAL(result)[ij] = REAL(x)[iijj];
break;
case CPLXSXP:
COMPLEX(result)[ij] = COMPLEX(x)[iijj];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(x, iijj));
break;
case VECSXP:
SET_VECTOR_ELT(result, ij, VECTOR_ELT_FIX_NAMED(x, iijj));
break;
case RAWSXP:
RAW(result)[ij] = RAW(x)[iijj];
break;
default:
errorcall(call, _("matrix subscripting not handled for this type"));
break;
}
}
}
}
if(nrs >= 0 && ncs >= 0) {
PROTECT(attr = allocVector(INTSXP, 2));
INTEGER(attr)[0] = nrs;
INTEGER(attr)[1] = ncs;
setAttrib(result, R_DimSymbol, attr);
UNPROTECT(1);
}
/* The matrix elements have been transferred. Now we need to */
/* transfer the attributes. Most importantly, we need to subset */
/* the dimnames of the returned value. */
if (nrs >= 0 && ncs >= 0) {
SEXP dimnames, dimnamesnames, newdimnames;
dimnames = getAttrib(x, R_DimNamesSymbol);
PROTECT(dimnamesnames = getAttrib(dimnames, R_NamesSymbol));
if (!isNull(dimnames)) {
PROTECT(newdimnames = allocVector(VECSXP, 2));
if (TYPEOF(dimnames) == VECSXP) {
SET_VECTOR_ELT(newdimnames, 0,
ExtractSubset(VECTOR_ELT(dimnames, 0),
allocVector(STRSXP, nrs), sr, call));
SET_VECTOR_ELT(newdimnames, 1,
ExtractSubset(VECTOR_ELT(dimnames, 1),
allocVector(STRSXP, ncs), sc, call));
}
else {
SET_VECTOR_ELT(newdimnames, 0,
ExtractSubset(CAR(dimnames),
allocVector(STRSXP, nrs), sr, call));
SET_VECTOR_ELT(newdimnames, 1,
ExtractSubset(CADR(dimnames),
allocVector(STRSXP, ncs), sc, call));
}
setAttrib(newdimnames, R_NamesSymbol, dimnamesnames);
setAttrib(result, R_DimNamesSymbol, newdimnames);
UNPROTECT(1); /* newdimnames */
}
UNPROTECT(1); /* dimnamesnames */
}
/* Probably should not do this:
copyMostAttrib(x, result); */
if (drop)
DropDims(result);
UNPROTECT(3);
return result;
}
/* {{{ rberkeley_dbcursor_get */
SEXP rberkeley_dbcursor_get (SEXP _dbc,
SEXP _key,
SEXP _data,
SEXP _flags,
SEXP _n /* non-API flag */)
{
DBC *dbc;
DBT key, data;
u_int32_t flags;
int i, n, ret, P=0;
flags = (u_int32_t)INTEGER(_flags)[0];
n = (INTEGER(_n)[0] < 0) ? 100 : INTEGER(_n)[0]; /* this should be _all_ data */
dbc = R_ExternalPtrAddr(_dbc);
if(R_ExternalPtrTag(_dbc) != install("DBC") || dbc == NULL)
error("invalid 'dbc' handle");
memset(&key, 0, sizeof(DBT));
memset(&data, 0, sizeof(DBT));
SEXP Keys, Data, results;
PROTECT(Keys = allocVector(VECSXP, n)); P++;
PROTECT(Data = allocVector(VECSXP, n)); P++;
PROTECT(results = allocVector(VECSXP, n)); P++;
/*
Two scenarios for DBcursor->get calls:
(1) key and data are SPECIFIED <OR> key is SPECIFIED, data is EMPTY
(2) key and data are EMPTY
We must handle these seperately in order
to return a sensible result
*/
if( (!isNull(_key) &&
!isNull(_data)) || !isNull(_key) ) {
/* need to handle cases where multiple results
can be returned. Possibly given that flag
we can instead use the last if-else branch */
key.data = (unsigned char *)RAW(_key);
key.size = length(_key);
if(!isNull(_data)) {
data.data = (unsigned char *)RAW(_data);
data.size = length(_data);
}
ret = dbc->get(dbc, &key, &data, flags);
if(ret == 0) {
SEXP KeyData;
PROTECT(KeyData = allocVector(VECSXP, 2));P++;
SEXP rawkey;
PROTECT(rawkey = allocVector(RAWSXP, key.size));
memcpy(RAW(rawkey), key.data, key.size);
SET_VECTOR_ELT(KeyData, 0, rawkey);
UNPROTECT(1);
SEXP rawdata;
PROTECT(rawdata = allocVector(RAWSXP, data.size));
memcpy(RAW(rawdata), data.data, data.size);
SET_VECTOR_ELT(KeyData, 1, rawdata);
UNPROTECT(1);
SEXP KeyDataNames;
PROTECT(KeyDataNames = allocVector(STRSXP,2)); P++;
SET_STRING_ELT(KeyDataNames, 0, mkChar("key"));
SET_STRING_ELT(KeyDataNames, 1, mkChar("data"));
setAttrib(KeyData, R_NamesSymbol, KeyDataNames);
SET_VECTOR_ELT(results, 0, KeyData);
PROTECT(results = lengthgets(results, 1)); P++;
}
} else
if(isNull(_key) && isNull(_data)) {
for(i = 0; i < n; i++) {
ret = dbc->get(dbc, &key, &data, flags);
if(ret == 0) {
SEXP KeyData;
PROTECT(KeyData = allocVector(VECSXP, 2));
SEXP rawkey;
PROTECT(rawkey = allocVector(RAWSXP, key.size));
memcpy(RAW(rawkey), key.data, key.size);
SET_VECTOR_ELT(KeyData, 0, rawkey);
SEXP rawdata;
PROTECT(rawdata = allocVector(RAWSXP, data.size));
memcpy(RAW(rawdata), data.data, data.size);
SET_VECTOR_ELT(KeyData, 1, rawdata);
SEXP KeyDataNames;
PROTECT(KeyDataNames = allocVector(STRSXP,2));
SET_STRING_ELT(KeyDataNames, 0, mkChar("key"));
SET_STRING_ELT(KeyDataNames, 1, mkChar("data"));
setAttrib(KeyData, R_NamesSymbol, KeyDataNames);
SET_VECTOR_ELT(results, i, KeyData);
UNPROTECT(4); /* KeyDataNames, rawdata, rawkey, KeyData */
} else { /* end of data */
if(i == 0) { /* no results */
UNPROTECT(P);
return ScalarInteger(ret);
}
/* truncate the keys and data to the i-size found */
PROTECT(results = lengthgets(results, i)); P++;
break;
}
}
}
UNPROTECT(P);
return results;
}
static SEXP ArraySubset(SEXP x, SEXP s, SEXP call, int drop)
{
int k, mode;
SEXP dimnames, dimnamesnames, p, q, r, result, xdims;
const void *vmaxsave = vmaxget();
mode = TYPEOF(x);
xdims = getAttrib(x, R_DimSymbol);
k = length(xdims);
/* k is now the number of dims */
int **subs = (int**)R_alloc(k, sizeof(int*));
int *indx = (int*)R_alloc(k, sizeof(int));
int *bound = (int*)R_alloc(k, sizeof(int));
R_xlen_t *offset = (R_xlen_t*)R_alloc(k, sizeof(R_xlen_t));
/* Construct a vector to contain the returned values. */
/* Store its extents. */
R_xlen_t n = 1;
r = s;
for (int i = 0; i < k; i++) {
SETCAR(r, int_arraySubscript(i, CAR(r), xdims, x, call));
bound[i] = LENGTH(CAR(r));
n *= bound[i];
r = CDR(r);
}
PROTECT(result = allocVector(mode, n));
r = s;
for (int i = 0; i < k; i++) {
indx[i] = 0;
subs[i] = INTEGER(CAR(r));
r = CDR(r);
}
offset[0] = 1;
for (int i = 1; i < k; i++)
offset[i] = offset[i - 1] * INTEGER(xdims)[i - 1];
/* Transfer the subset elements from "x" to "a". */
for (R_xlen_t i = 0; i < n; i++) {
R_xlen_t ii = 0;
for (int j = 0; j < k; j++) {
int jj = subs[j][indx[j]];
if (jj == NA_INTEGER) {
ii = NA_INTEGER;
goto assignLoop;
}
if (jj < 1 || jj > INTEGER(xdims)[j])
errorcall(call, R_MSG_subs_o_b);
ii += (jj - 1) * offset[j];
}
assignLoop:
switch (mode) {
case LGLSXP:
if (ii != NA_INTEGER)
LOGICAL(result)[i] = LOGICAL(x)[ii];
else
LOGICAL(result)[i] = NA_LOGICAL;
break;
case INTSXP:
if (ii != NA_INTEGER)
INTEGER(result)[i] = INTEGER(x)[ii];
else
INTEGER(result)[i] = NA_INTEGER;
break;
case REALSXP:
if (ii != NA_INTEGER)
REAL(result)[i] = REAL(x)[ii];
else
REAL(result)[i] = NA_REAL;
break;
case CPLXSXP:
if (ii != NA_INTEGER) {
COMPLEX(result)[i] = COMPLEX(x)[ii];
}
else {
COMPLEX(result)[i].r = NA_REAL;
COMPLEX(result)[i].i = NA_REAL;
}
break;
case STRSXP:
if (ii != NA_INTEGER)
SET_STRING_ELT(result, i, STRING_ELT(x, ii));
else
SET_STRING_ELT(result, i, NA_STRING);
break;
case VECSXP:
if (ii != NA_INTEGER)
SET_VECTOR_ELT(result, i, VECTOR_ELT_FIX_NAMED(x, ii));
else
SET_VECTOR_ELT(result, i, R_NilValue);
break;
case RAWSXP:
if (ii != NA_INTEGER)
RAW(result)[i] = RAW(x)[ii];
else
RAW(result)[i] = (Rbyte) 0;
break;
default:
errorcall(call, _("array subscripting not handled for this type"));
break;
}
if (n > 1) {
int j = 0;
while (++indx[j] >= bound[j]) {
indx[j] = 0;
j = (j + 1) % k;
}
}
}
PROTECT(xdims = allocVector(INTSXP, k));
for(int i = 0 ; i < k ; i++)
INTEGER(xdims)[i] = bound[i];
setAttrib(result, R_DimSymbol, xdims);
UNPROTECT(1); /* xdims */
/* The array elements have been transferred. */
/* Now we need to transfer the attributes. */
/* Most importantly, we need to subset the */
/* dimnames of the returned value. */
dimnames = getAttrib(x, R_DimNamesSymbol);
PROTECT(dimnamesnames = getAttrib(dimnames, R_NamesSymbol));
if (dimnames != R_NilValue) {
int j = 0;
PROTECT(xdims = allocVector(VECSXP, k));
if (TYPEOF(dimnames) == VECSXP) {
r = s;
for (int i = 0; i < k ; i++) {
if (bound[i] > 0) {
SET_VECTOR_ELT(xdims, j++,
ExtractSubset(VECTOR_ELT(dimnames, i),
allocVector(STRSXP, bound[i]),
CAR(r), call));
} else { /* 0-length dims have NULL dimnames */
SET_VECTOR_ELT(xdims, j++, R_NilValue);
}
r = CDR(r);
}
}
else {
p = dimnames;
q = xdims;
r = s;
for(int i = 0 ; i < k; i++) {
SETCAR(q, allocVector(STRSXP, bound[i]));
SETCAR(q, ExtractSubset(CAR(p), CAR(q), CAR(r), call));
p = CDR(p);
q = CDR(q);
r = CDR(r);
}
}
setAttrib(xdims, R_NamesSymbol, dimnamesnames);
setAttrib(result, R_DimNamesSymbol, xdims);
UNPROTECT(1); /* xdims */
}
/* This was removed for matrices in 1998
copyMostAttrib(x, result); */
/* Free temporary memory */
vmaxset(vmaxsave);
if (drop)
DropDims(result);
UNPROTECT(2); /* dimnamesnames, result */
return result;
}
/* "%*%" (op = 0), crossprod (op = 1) or tcrossprod (op = 2) */
SEXP attribute_hidden do_earg_matprod(SEXP call, SEXP op, SEXP arg_x, SEXP arg_y, SEXP rho)
{
int ldx, ldy, nrx, ncx, nry, ncy, mode;
SEXP x = arg_x, y = arg_y, xdims, ydims, ans;
Rboolean sym;
sym = isNull(y);
if (sym && (PRIMVAL(op) > 0)) y = x;
if ( !(isNumeric(x) || isComplex(x)) || !(isNumeric(y) || isComplex(y)) )
errorcall(call, _("requires numeric/complex matrix/vector arguments"));
xdims = getDimAttrib(x);
ydims = getDimAttrib(y);
ldx = length(xdims);
ldy = length(ydims);
if (ldx != 2 && ldy != 2) { /* x and y non-matrices */
if (PRIMVAL(op) == 0) {
nrx = 1;
ncx = LENGTH(x);
}
else {
nrx = LENGTH(x);
ncx = 1;
}
nry = LENGTH(y);
ncy = 1;
}
else if (ldx != 2) { /* x not a matrix */
nry = INTEGER(ydims)[0];
ncy = INTEGER(ydims)[1];
nrx = 0;
ncx = 0;
if (PRIMVAL(op) == 0) {
if (LENGTH(x) == nry) { /* x as row vector */
nrx = 1;
ncx = nry; /* == LENGTH(x) */
}
else if (nry == 1) { /* x as col vector */
nrx = LENGTH(x);
ncx = 1;
}
}
else if (PRIMVAL(op) == 1) { /* crossprod() */
if (LENGTH(x) == nry) { /* x is a col vector */
nrx = nry; /* == LENGTH(x) */
ncx = 1;
}
/* else if (nry == 1) ... not being too tolerant
to treat x as row vector, as t(x) *is* row vector */
}
else { /* tcrossprod */
if (LENGTH(x) == ncy) { /* x as row vector */
nrx = 1;
ncx = ncy; /* == LENGTH(x) */
}
else if (ncy == 1) { /* x as col vector */
nrx = LENGTH(x);
ncx = 1;
}
}
}
else if (ldy != 2) { /* y not a matrix */
nrx = INTEGER(xdims)[0];
ncx = INTEGER(xdims)[1];
nry = 0;
ncy = 0;
if (PRIMVAL(op) == 0) {
if (LENGTH(y) == ncx) { /* y as col vector */
nry = ncx;
ncy = 1;
}
else if (ncx == 1) { /* y as row vector */
nry = 1;
ncy = LENGTH(y);
}
}
else if (PRIMVAL(op) == 1) { /* crossprod() */
if (LENGTH(y) == nrx) { /* y is a col vector */
nry = nrx;
ncy = 1;
}
}
else { /* tcrossprod -- y is a col vector */
nry = LENGTH(y);
ncy = 1;
}
}
else { /* x and y matrices */
nrx = INTEGER(xdims)[0];
ncx = INTEGER(xdims)[1];
nry = INTEGER(ydims)[0];
ncy = INTEGER(ydims)[1];
}
/* nr[ow](.) and nc[ol](.) are now defined for x and y */
if (PRIMVAL(op) == 0) {
/* primitive, so use call */
if (ncx != nry)
errorcall(call, _("non-conformable arguments"));
}
else if (PRIMVAL(op) == 1) {
if (nrx != nry)
error(_("non-conformable arguments"));
}
else {
if (ncx != ncy)
error(_("non-conformable arguments"));
}
if (isComplex(x) || isComplex(y))
mode = CPLXSXP;
else
mode = REALSXP;
x = coerceVector(x, mode);
y = coerceVector(y, mode);
if (PRIMVAL(op) == 0) { /* op == 0 : matprod() */
PROTECT(ans = allocMatrix(mode, nrx, ncy));
if (mode == CPLXSXP)
cmatprod(COMPLEX(x), nrx, ncx,
COMPLEX(y), nry, ncy, COMPLEX(ans));
else
matprod(REAL(x), nrx, ncx,
REAL(y), nry, ncy, REAL(ans));
PROTECT(xdims = getDimNamesAttrib(x));
PROTECT(ydims = getDimNamesAttrib(y));
if (xdims != R_NilValue || ydims != R_NilValue) {
SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue;
/* allocate dimnames and dimnamesnames */
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(dimnamesnames = allocVector(STRSXP, 2));
if (xdims != R_NilValue) {
if (ldx == 2 || ncx == 1) {
SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 0));
dnx = getNamesAttrib(xdims);
if(!isNull(dnx))
SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 0));
}
}
#define YDIMS_ET_CETERA \
if (ydims != R_NilValue) { \
if (ldy == 2) { \
SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 1)); \
dny = getNamesAttrib(ydims); \
if(!isNull(dny)) \
SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 1)); \
} else if (nry == 1) { \
SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 0)); \
dny = getNamesAttrib(ydims); \
if(!isNull(dny)) \
SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 0)); \
} \
} \
\
/* We sometimes attach a dimnames attribute \
* whose elements are all NULL ... \
* This is ugly but causes no real damage. \
* Now (2.1.0 ff), we don't anymore: */ \
if (VECTOR_ELT(dimnames,0) != R_NilValue || \
VECTOR_ELT(dimnames,1) != R_NilValue) { \
if (dnx != R_NilValue || dny != R_NilValue) \
setAttrib(dimnames, R_NamesSymbol, dimnamesnames); \
setAttrib(ans, R_DimNamesSymbol, dimnames); \
} \
UNPROTECT(2)
YDIMS_ET_CETERA;
}
}
else if (PRIMVAL(op) == 1) { /* op == 1: crossprod() */
PROTECT(ans = allocMatrix(mode, ncx, ncy));
if (mode == CPLXSXP)
if(sym)
ccrossprod(COMPLEX(x), nrx, ncx,
COMPLEX(x), nry, ncy, COMPLEX(ans));
else
ccrossprod(COMPLEX(x), nrx, ncx,
COMPLEX(y), nry, ncy, COMPLEX(ans));
else {
if(sym)
symcrossprod(REAL(x), nrx, ncx, REAL(ans));
else
crossprod(REAL(x), nrx, ncx,
REAL(y), nry, ncy, REAL(ans));
}
PROTECT(xdims = getDimNamesAttrib(x));
if (sym)
PROTECT(ydims = xdims);
else
PROTECT(ydims = getDimNamesAttrib(y));
if (xdims != R_NilValue || ydims != R_NilValue) {
SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue;
/* allocate dimnames and dimnamesnames */
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(dimnamesnames = allocVector(STRSXP, 2));
if (xdims != R_NilValue) {
if (ldx == 2) {/* not nrx==1 : .. fixed, ihaka 2003-09-30 */
SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 1));
dnx = getNamesAttrib(xdims);
if(!isNull(dnx))
SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 1));
}
}
YDIMS_ET_CETERA;
}
}
else { /* op == 2: tcrossprod() */
PROTECT(ans = allocMatrix(mode, nrx, nry));
if (mode == CPLXSXP)
if(sym)
tccrossprod(COMPLEX(x), nrx, ncx,
COMPLEX(x), nry, ncy, COMPLEX(ans));
else
tccrossprod(COMPLEX(x), nrx, ncx,
COMPLEX(y), nry, ncy, COMPLEX(ans));
else {
if(sym)
symtcrossprod(REAL(x), nrx, ncx, REAL(ans));
else
tcrossprod(REAL(x), nrx, ncx,
REAL(y), nry, ncy, REAL(ans));
}
PROTECT(xdims = getDimNamesAttrib(x));
if (sym)
PROTECT(ydims = xdims);
else
PROTECT(ydims = getDimNamesAttrib(y));
if (xdims != R_NilValue || ydims != R_NilValue) {
SEXP dimnames, dimnamesnames, dnx=R_NilValue, dny=R_NilValue;
/* allocate dimnames and dimnamesnames */
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(dimnamesnames = allocVector(STRSXP, 2));
if (xdims != R_NilValue) {
if (ldx == 2) {
SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(xdims, 0));
dnx = getNamesAttrib(xdims);
if(!isNull(dnx))
SET_STRING_ELT(dimnamesnames, 0, STRING_ELT(dnx, 0));
}
}
if (ydims != R_NilValue) {
if (ldy == 2) {
SET_VECTOR_ELT(dimnames, 1, VECTOR_ELT(ydims, 0));
dny = getNamesAttrib(ydims);
if(!isNull(dny))
SET_STRING_ELT(dimnamesnames, 1, STRING_ELT(dny, 0));
}
}
if (VECTOR_ELT(dimnames,0) != R_NilValue ||
VECTOR_ELT(dimnames,1) != R_NilValue) {
if (dnx != R_NilValue || dny != R_NilValue)
setAttrib(dimnames, R_NamesSymbol, dimnamesnames);
setAttrib(ans, R_DimNamesSymbol, dimnames);
}
UNPROTECT(2);
}
}
UNPROTECT(3);
return ans;
}
SEXP R_get_qgrams(SEXP a, SEXP qq){
PROTECT(a);
PROTECT(qq);
int q = INTEGER(qq)[0];
if ( q < 0 ){
UNPROTECT(2);
error("q must be a nonnegative integer");
}
SEXP strlist;
int nstr, nchar, nLoc = length(a);
unsigned int *str;
// set up a tree; push all the qgrams.
qtree *Q = new_qtree( q, nLoc);
for ( int iLoc = 0; iLoc < nLoc; ++iLoc ){
strlist = VECTOR_ELT(a, iLoc);
nstr = length(strlist);
for ( int i=0; i < nstr; ++i ){
str = (unsigned int *) INTEGER(VECTOR_ELT(strlist,i));
nchar = length(VECTOR_ELT(strlist,i));
if ( str[0] == NA_INTEGER
|| q > nchar
|| ( q == 0 && nchar > 0 )
){
continue ;
}
Q = push_string(str, nchar, q, Q, iLoc, nLoc);
if ( Q == NULL ){
UNPROTECT(2);
error("could not allocate enough memory");
}
}
}
// pick and delete the tree
int nqgram[1] = {0};
// helper variable for get_counts
int index[1] = {0};
count_qtree(Q,nqgram);
SEXP qgrams, qcount;
PROTECT(qgrams = allocVector(INTSXP, q*nqgram[0]));
PROTECT(qcount = allocVector(REALSXP, nLoc*nqgram[0]));
get_counts(Q, q, INTEGER(qgrams), nLoc, index, REAL(qcount));
setAttrib(qcount, install("qgrams"), qgrams);
free_qtree();
UNPROTECT(4);
return(qcount);
}
