inline R_adjacency_list(SEXP num_verts_in,
SEXP num_edges_in,
SEXP R_edges_in,
SEXP R_weights_in)
: Base(Rf_asInteger(num_verts_in))
{
if (!Rf_isNumeric(R_weights_in)) error("R_weights_in should be Numeric");
if (!Rf_isInteger(R_edges_in)) error("R_edges_in should be integer");
int NE = Rf_asInteger(num_edges_in);
int* edges_in = INTEGER(R_edges_in);
if (Rf_isReal(R_weights_in)) {
if (boost::is_integral<R_weight_type>::value)
error("R_weights_in should be integer");
else {
double* weights_in = REAL(R_weights_in);
for (int i = 0; i < NE ; i++, edges_in += 2, weights_in++) {
boost::add_edge(*edges_in, *(edges_in+1),
*weights_in, *this);
}
}
} else {
int* weights_in = INTEGER(R_weights_in);
for (int i = 0; i < NE ; i++, edges_in += 2, weights_in++) {
boost::add_edge(*edges_in, *(edges_in+1), *weights_in, *this);
}
}
}
inline R_adjacency_list(SEXP num_verts_in,
SEXP num_edges_in,
SEXP R_edges_in)
: Base(Rf_asInteger(num_verts_in))
{
if (!Rf_isInteger(R_edges_in)) error("R_edges_in should be integer");
int NE = Rf_asInteger(num_edges_in);
int* edges_in = INTEGER(R_edges_in);
for (int i = 0; i < NE ; i++, edges_in += 2) {
boost::add_edge(*edges_in, *(edges_in+1), 1, *this);
}
}
void AlgebraFitFunction::init()
{
auto *off = this;
omxState *currentState = off->matrix->currentState;
AlgebraFitFunction *aff = this;
aff->ff = off;
ProtectedSEXP Ralg(R_do_slot(rObj, Rf_install("algebra")));
aff->algebra = omxMatrixLookupFromState1(Ralg, currentState);
ProtectedSEXP Runit(R_do_slot(rObj, Rf_install("units")));
off->setUnitsFromName(CHAR(STRING_ELT(Runit, 0)));
ProtectedSEXP Rgr(R_do_slot(rObj, Rf_install("gradient")));
aff->gradient = omxMatrixLookupFromState1(Rgr, currentState);
if (aff->gradient) off->gradientAvailable = TRUE;
ProtectedSEXP Rh(R_do_slot(rObj, Rf_install("hessian")));
aff->hessian = omxMatrixLookupFromState1(Rh, currentState);
if (aff->hessian) off->hessianAvailable = TRUE;
ProtectedSEXP Rverb(R_do_slot(rObj, Rf_install("verbose")));
aff->verbose = Rf_asInteger(Rverb);
off->canDuplicate = true;
}
static SEXP setNumberOfCores(SEXP num)
{
omxManageProtectInsanity mpi;
#if defined(_OPENMP)
GlobalNumberOfCores = Rf_asInteger(num);
#endif
return num;
}
SEXP ocl_get_device_info_char(SEXP device, SEXP item) {
cl_device_id device_id = getDeviceID(device);
cl_device_info pn = (cl_device_info) Rf_asInteger(item);
*infobuf = 0;
if ((last_ocl_error = clGetDeviceInfo(device_id, pn, sizeof(infobuf), &infobuf, NULL)) != CL_SUCCESS)
ocl_err("clGetDeviceInfo");
return Rf_mkString(infobuf);
}
SEXP ocl_get_device_info_char(SEXP device, SEXP item) {
char buf[512];
cl_device_id device_id = getDeviceID(device);
cl_device_info pn = (cl_device_info) Rf_asInteger(item);
buf[0] = 0;
if (clGetDeviceInfo(device_id, pn, sizeof(buf), &buf, NULL) != CL_SUCCESS)
ocl_err("clGetDeviceInfo");
return Rf_mkString(buf);
}
void seed_rng_from_R(SEXP rseed) {
if (Rf_isNull(rseed)) {
BOOM::GlobalRng::seed_with_timestamp();
} else {
int seed = Rf_asInteger(rseed);
BOOM::GlobalRng::rng.seed(seed);
srand(seed);
}
}
SEXP cr_connect(SEXP sHost, SEXP sPort, SEXP sTimeout, SEXP sReconnect, SEXP sRetry) {
const char *host = "localhost";
double tout = Rf_asReal(sTimeout);
int port = Rf_asInteger(sPort), reconnect = (Rf_asInteger(sReconnect) > 0),
retry = (Rf_asInteger(sRetry) > 0);
redisContext *ctx;
rconn_t *c;
SEXP res;
struct timeval tv;
if (TYPEOF(sHost) == STRSXP && LENGTH(sHost) > 0)
host = CHAR(STRING_ELT(sHost, 0));
tv.tv_sec = (int) tout;
tv.tv_usec = (tout - (double)tv.tv_sec) * 1000000.0;
if (port < 1)
ctx = redisConnectUnixWithTimeout(host, tv);
else
ctx = redisConnectWithTimeout(host, port, tv);
if (!ctx) Rf_error("connect to redis failed (NULL context)");
if (ctx->err){
SEXP es = Rf_mkChar(ctx->errstr);
redisFree(ctx);
Rf_error("connect to redis failed: %s", CHAR(es));
}
c = malloc(sizeof(rconn_t));
if (!c) {
redisFree(ctx);
Rf_error("unable to allocate connection context");
}
c->rc = ctx;
c->flags = (reconnect ? RCF_RECONNECT : 0) | (retry ? RCF_RETRY : 0);
c->host = strdup(host);
c->port = port;
c->timeout = tout;
redisSetTimeout(ctx, tv);
res = PROTECT(R_MakeExternalPtr(c, R_NilValue, R_NilValue));
Rf_setAttrib(res, R_ClassSymbol, Rf_mkString("redisConnection"));
R_RegisterCFinalizer(res, rconn_fin);
UNPROTECT(1);
return res;
}
void omxFillMatrixFromMxFitFunction(omxMatrix* om, int matrixNumber, SEXP rObj)
{
om->hasMatrixNumber = TRUE;
om->matrixNumber = matrixNumber;
ProtectedSEXP fitFunctionClass(STRING_ELT(Rf_getAttrib(rObj, R_ClassSymbol), 0));
const char *fitType = CHAR(fitFunctionClass);
omxExpectation *expect = NULL;
ProtectedSEXP slotValue(R_do_slot(rObj, Rf_install("expectation")));
if (Rf_length(slotValue) == 1) {
int expNumber = Rf_asInteger(slotValue);
if(expNumber != NA_INTEGER) {
expect = omxExpectationFromIndex(expNumber, om->currentState);
}
}
bool rowLik = Rf_asInteger(R_do_slot(rObj, Rf_install("vector")));
omxFitFunction *ff =
omxNewInternalFitFunction(om->currentState, fitType, expect, om, rowLik);
ff->rObj = rObj;
}
void omxFillMatrixFromMxFitFunction(omxMatrix* om, const char *fitType, int matrixNumber, SEXP rObj)
{
om->hasMatrixNumber = TRUE;
om->matrixNumber = matrixNumber;
SEXP slotValue;
omxExpectation *expect = NULL;
{
ScopedProtect p1(slotValue, R_do_slot(rObj, Rf_install("expectation")));
if (Rf_length(slotValue) == 1) {
int expNumber = Rf_asInteger(slotValue);
if(expNumber != NA_INTEGER) {
expect = omxExpectationFromIndex(expNumber, om->currentState);
}
}
}
bool rowLik = Rf_asInteger(R_do_slot(rObj, Rf_install("vector")));
omxFitFunction *ff =
omxNewInternalFitFunction(om->currentState, fitType, expect, om, rowLik);
ff->rObj = rObj;
}
// Does vector=TRUE mean something sensible? Mixture of mixtures?
void state::init()
{
auto *oo = this;
auto *ms = this;
if (!oo->expectation) { mxThrow("%s requires an expectation", oo->fitType); }
oo->units = FIT_UNITS_MINUS2LL;
oo->canDuplicate = true;
omxState *currentState = oo->matrix->currentState;
const char *myex1 = "MxExpectationHiddenMarkov";
const char *myex2 = "MxExpectationMixture";
if (!expectation || !(strEQ(expectation->expType, myex1) ||
strEQ(expectation->expType, myex2)))
mxThrow("%s must be paired with %s or %s", oo->name(), myex1, myex2);
ProtectedSEXP Rverbose(R_do_slot(oo->rObj, Rf_install("verbose")));
ms->verbose = Rf_asInteger(Rverbose);
ProtectedSEXP Rcomponents(R_do_slot(oo->rObj, Rf_install("components")));
int nc = Rf_length(Rcomponents);
int *cvec = INTEGER(Rcomponents);
componentUnits = FIT_UNITS_UNINITIALIZED;
for (int cx=0; cx < nc; ++cx) {
omxMatrix *fmat = currentState->algebraList[ cvec[cx] ];
if (fmat->fitFunction) {
omxCompleteFitFunction(fmat);
auto ff = fmat->fitFunction;
if (ff->units != FIT_UNITS_PROBABILITY) {
omxRaiseErrorf("%s: component %s must be in probability units",
oo->name(), ff->name());
return;
}
if (componentUnits == FIT_UNITS_UNINITIALIZED) {
componentUnits = ff->units;
} else if (ff->units != componentUnits) {
omxRaiseErrorf("%s: components with heterogenous units %s and %s in same mixture",
oo->name(), fitUnitsToName(ff->units), fitUnitsToName(componentUnits));
}
}
ms->components.push_back(fmat);
}
if (componentUnits == FIT_UNITS_UNINITIALIZED) componentUnits = FIT_UNITS_PROBABILITY;
ms->initial = expectation->getComponent("initial");
ms->transition = expectation->getComponent("transition");
}
/* set the length ofthe clFloat object, effectively resizing it */
SEXP clFloat_length_set(SEXP fObject, SEXP value) {
SEXP res;
int newLen = Rf_asInteger(value), cpy;
if (newLen == LENGTH(fObject)) return fObject;
if (newLen < 0)
Rf_error("invalid length");
if (newLen > 536870912)
Rf_error("clFloat length cannot exceed 512Mb due to R vector length limitations");
newLen *= sizeof(float);
res = PROTECT(Rf_allocVector(RAWSXP, newLen));
cpy = (newLen > LENGTH(fObject)) ? LENGTH(fObject) : newLen;
memcpy(RAW(res), RAW(fObject), cpy);
if (newLen > cpy) /* FIXME: we initialize to 0.0 - maybe we need NAs ? */
memset(RAW(res) + cpy, 0, newLen - cpy);
Rf_setAttrib(res, R_ClassSymbol, Rf_mkString("clFloat"));
UNPROTECT(1);
return res;
}
void FitMultigroup::init()
{
auto *oo = this;
FitMultigroup *mg =this;
SEXP rObj = oo->rObj;
if (!rObj) return;
if (mg->fits.size()) return; // hack to prevent double initialization, remove TOOD
oo->units = FIT_UNITS_UNINITIALIZED;
oo->gradientAvailable = TRUE;
oo->hessianAvailable = TRUE;
oo->canDuplicate = true;
omxState *os = oo->matrix->currentState;
ProtectedSEXP Rverb(R_do_slot(rObj, Rf_install("verbose")));
mg->verbose = Rf_asInteger(Rverb);
ProtectedSEXP Rgroups(R_do_slot(rObj, Rf_install("groups")));
int *fits = INTEGER(Rgroups);
for(int gx = 0; gx < Rf_length(Rgroups); gx++) {
if (isErrorRaised()) break;
omxMatrix *mat;
if (fits[gx] >= 0) {
mat = os->algebraList[fits[gx]];
} else {
mxThrow("Can only add algebra and fitfunction");
}
if (mat == oo->matrix) mxThrow("Cannot add multigroup to itself");
mg->fits.push_back(mat);
if (mat->fitFunction) {
omxCompleteFitFunction(mat);
oo->gradientAvailable = (oo->gradientAvailable && mat->fitFunction->gradientAvailable);
oo->hessianAvailable = (oo->hessianAvailable && mat->fitFunction->hessianAvailable);
} else {
oo->gradientAvailable = FALSE;
oo->hessianAvailable = FALSE;
}
}
}
SEXP audio_recorder(SEXP source, SEXP rate, SEXP channels) {
float fRate = -1.0;
int chs = Rf_asInteger(channels);
if (!current_driver)
load_default_audio_driver(0);
if (TYPEOF(rate) == INTSXP || TYPEOF(rate) == REALSXP)
fRate = (float) Rf_asReal(rate);
if (chs < 1) chs = 1;
if (!current_driver->create_recorder)
Rf_error("the currently used audio driver doesn't support recording");
audio_instance_t *p = current_driver->create_recorder(source, fRate, chs, 0);
if (!p) Rf_error("cannot start audio driver");
p->driver = current_driver;
p->kind = AI_RECORDER;
SEXP ptr = R_MakeExternalPtr(p, R_NilValue, R_NilValue);
Rf_protect(ptr);
R_RegisterCFinalizer(ptr, audio_instance_destructor);
Rf_setAttrib(ptr, Rf_install("class"), Rf_mkString("audioInstance"));
Rf_unprotect(1);
return ptr;
}
void MarkovExpectation::init()
{
ProtectedSEXP Rverbose(R_do_slot(rObj, Rf_install("verbose")));
verbose = Rf_asInteger(Rverbose);
ProtectedSEXP Rcomponents(R_do_slot(rObj, Rf_install("components")));
int *cvec = INTEGER(Rcomponents);
int nc = Rf_length(Rcomponents);
for (int cx=0; cx < nc; ++cx) {
components.push_back(omxExpectationFromIndex(cvec[cx], currentState));
}
if (isMixtureInterface) {
initial = omxNewMatrixFromSlot(rObj, currentState, "weights");
transition = 0;
} else {
initial = omxNewMatrixFromSlot(rObj, currentState, "initial");
transition = omxNewMatrixFromSlot(rObj, currentState, "transition");
}
ProtectedSEXP Rscale(R_do_slot(rObj, Rf_install("scale")));
auto scaleName = CHAR(STRING_ELT(Rscale, 0));
if (strEQ(scaleName, "softmax")) {
scale = SCALE_SOFTMAX;
} else if (strEQ(scaleName, "sum")) {
scale = SCALE_SUM;
} else if (strEQ(scaleName, "none")) {
scale = SCALE_NONE;
} else {
Rf_error("%s: unknown scale '%s'", name, scaleName);
}
scaledInitial = omxInitMatrix(1, 1, TRUE, currentState);
scaledTransition = 0;
if (transition) {
scaledTransition = omxInitMatrix(1, 1, TRUE, currentState);
}
}
void omxInitFitFunctionBA81(omxFitFunction* oo)
{
if (!oo->argStruct) { // ugh!
BA81FitState *state = new BA81FitState;
oo->argStruct = state;
}
omxState *currentState = oo->matrix->currentState;
BA81FitState *state = (BA81FitState*) oo->argStruct;
omxExpectation *expectation = oo->expectation;
BA81Expect *estate = (BA81Expect*) expectation->argStruct;
estate->fit = oo;
oo->computeFun = ba81Compute;
oo->setVarGroup = ba81SetFreeVarGroup;
oo->destructFun = ba81Destroy;
oo->gradientAvailable = TRUE;
oo->hessianAvailable = TRUE;
int maxParam = estate->itemParam->rows;
state->itemDerivPadSize = maxParam + triangleLoc1(maxParam);
int numItems = estate->itemParam->cols;
for (int ix=0; ix < numItems; ix++) {
const double *spec = estate->itemSpec(ix);
int id = spec[RPF_ISpecID];
if (id < 0 || id >= Glibrpf_numModels) {
Rf_error("ItemSpec %d has unknown item model %d", ix, id);
}
}
state->itemParam = omxInitMatrix(0, 0, TRUE, currentState);
state->latentMean = omxInitMatrix(0, 0, TRUE, currentState);
state->latentCov = omxInitMatrix(0, 0, TRUE, currentState);
state->copyEstimates(estate);
state->returnRowLikelihoods = Rf_asInteger(R_do_slot(oo->rObj, Rf_install("vector")));
}
SEXP
makeVector(SEXP ans, int len, int type, SEXP nullValue)
{
SEXP tmp;
int ctr;
if(type == REALSXP) {
PROTECT(tmp = NEW_NUMERIC(len));
for(ctr = 0; ctr < len; ctr++) {
SEXP el = VECTOR_ELT(ans, ctr);
REAL(tmp)[ctr] = TYPEOF(el) == LGLSXP && LOGICAL(el)[0] == NA_INTEGER ? NA_REAL : (TYPEOF(el) == REALSXP ? REAL(el)[0] : Rf_asReal(el));
}
} else if(type == LGLSXP) {
PROTECT(tmp = NEW_LOGICAL(len));
for(ctr = 0; ctr < len; ctr++) {
SEXP el = VECTOR_ELT(ans, ctr);
LOGICAL(tmp)[ctr] = TYPEOF(el) == LGLSXP ? LOGICAL(el)[0] : Rf_asInteger(el);
}
} else if(type == STRSXP) {
PROTECT(tmp = NEW_CHARACTER(len));
for(ctr = 0; ctr < len; ctr++) {
SEXP el = VECTOR_ELT(ans, ctr);
if(TYPEOF(el) == STRSXP)
SET_STRING_ELT(tmp, ctr, STRING_ELT(el, 0));
else if(TYPEOF(el) == LGLSXP) {
SET_STRING_ELT(tmp, ctr, LOGICAL(el)[0] == NA_INTEGER ? NA_STRING : mkChar(LOGICAL(el)[0] ? "TRUE" : "FALSE"));
} else if(TYPEOF(el) == REALSXP) {
char buf[70];
sprintf(buf, "%lf", REAL(el)[0]);
SET_STRING_ELT(tmp, ctr, mkChar(buf));
}
}
} else
return(ans);
UNPROTECT(1);
return(tmp);
}
static SEXP
rpf_paramInfo_wrapper(SEXP r_spec, SEXP r_paramNum)
{
if (Rf_length(r_spec) < RPF_ISpecCount)
Rf_error("Item spec must be of length %d, not %d", RPF_ISpecCount, Rf_length(r_spec));
double *spec = REAL(r_spec);
int id = spec[RPF_ISpecID];
if (id < 0 || id >= Glibrpf_numModels)
Rf_error("Item model %d out of range", id);
int pnum = Rf_asInteger(r_paramNum);
int numParam = (*Glibrpf_model[id].numParam)(spec);
if (pnum < 0 || pnum >= numParam) Rf_error("Item model %d has %d parameters", id, numParam);
const char *type;
double upper, lower;
(*Glibrpf_model[id].paramInfo)(spec, pnum, &type, &upper, &lower);
int len = 3;
SEXP names, ans;
Rf_protect(names = Rf_allocVector(STRSXP, len));
Rf_protect(ans = Rf_allocVector(VECSXP, len));
int lx = 0;
SET_STRING_ELT(names, lx, Rf_mkChar("type"));
SET_VECTOR_ELT(ans, lx, Rf_ScalarString(Rf_mkChar(type)));
SET_STRING_ELT(names, ++lx, Rf_mkChar("upper"));
SET_VECTOR_ELT(ans, lx, Rf_ScalarReal(std::isfinite(upper)? upper : NA_REAL));
SET_STRING_ELT(names, ++lx, Rf_mkChar("lower"));
SET_VECTOR_ELT(ans, lx, Rf_ScalarReal(std::isfinite(lower)? lower : NA_REAL));
Rf_namesgets(ans, names);
UNPROTECT(2);
return ans;
}
SEXP newJavaGD(SEXP sName, SEXP sWidth, SEXP sHeight, SEXP sSizeUnit,
SEXP sXpinch, SEXP sYpinch, SEXP sCanvasColor,
SEXP sPointsize, SEXP sGamma) {
double width = Rf_asReal(sWidth);
double height = Rf_asReal(sHeight);
if (!R_FINITE(width) || width < 0.0) {
error("Illegal argument: width");
}
if (!R_FINITE(height) || height < 0.0) {
error("Illegal argument: height");
}
int sizeUnit = Rf_asInteger(sSizeUnit);
double xpinch = Rf_asReal(sXpinch);
double ypinch = Rf_asReal(sYpinch);
if (!R_FINITE(xpinch) || xpinch <= 0.0) {
xpinch = 0.0;
ypinch = 0.0;
} else if (!R_FINITE(ypinch)) {
ypinch = xpinch;
}
int canvas = Rf_RGBpar(sCanvasColor, 0);
double pointsize = Rf_asReal(sPointsize);
double gamma = Rf_asReal(sGamma);
if (!R_FINITE(gamma)) {
gamma = 1.0;
}
addJavaGDDevice("", width, height, sizeUnit,
xpinch, ypinch, canvas,
pointsize, gamma );
return R_NilValue;
}
SEXP R_NewHashedEnv(SEXP parent, SEXP size) {
JNIEnv *thisenv = getEnv();
int sizeAsInt = Rf_asInteger(size);
SEXP result = (*thisenv)->CallStaticObjectMethod(thisenv, RDataFactoryClass, Rf_NewHashedEnvMethodID, parent, NULL, JNI_TRUE, sizeAsInt);
return checkRef(thisenv, result);
}
Rconnection get_connection(SEXP con) {
if (!Rf_inherits(con, "connection"))
Rcpp::stop("invalid connection");
return getConnection(Rf_asInteger(con));
}
SEXP find_password(SEXP svc, SEXP usr, SEXP new_pwd, SEXP quiet, SEXP del) {
SEXP res;
OSStatus status;
SecKeychainRef kc = NULL; /* default */
SecKeychainItemRef kci;
const char *un, *sn;
char *svc_name;
void *pwd;
UInt32 pwd_len = 0;
int l;
int silent = Rf_asInteger(quiet) == 1;
int do_rm = Rf_asInteger(del) == 1;
int modify = 0;
if (TYPEOF(svc) != STRSXP || LENGTH(svc) != 1) Rf_error("Invalid service name");
if (new_pwd != R_NilValue && (TYPEOF(new_pwd) != STRSXP || LENGTH(new_pwd) != 1))
Rf_error("Invalid password");
if (new_pwd != R_NilValue || do_rm) modify = 1;
if (usr == R_NilValue) {
un = getlogin();
if (!un) Rf_error("Unable to get current user name via getlogin()");
} else {
if (TYPEOF(usr) != STRSXP || LENGTH(usr) != 1)
Rf_error("Invalid user name (must be a character vector of length one)");
un = Rf_translateCharUTF8(STRING_ELT(usr, 0));
}
sn = Rf_translateCharUTF8(STRING_ELT(svc, 0));
l = strlen(sn);
if (l > sizeof(buf) - 16) {
svc_name = (char*) malloc(l + 16);
if (!svc_name) Rf_error("Cannot allocate memory for service name");
} else svc_name = buf;
/* we are enforcing R.keychain. prefix to avoid abuse to access other system keys */
strcpy(svc_name, SEC_PREFIX);
strcat(svc_name, sn);
status = SecKeychainFindGenericPassword(kc,
strlen(svc_name), svc_name,
strlen(un), un,
&pwd_len, &pwd,
modify ? &kci : NULL);
if (svc_name != buf) free(svc_name);
if (silent && status == errSecItemNotFound) return R_NilValue;
chk_status(status, "find");
res = PROTECT(Rf_ScalarString(Rf_mkCharLenCE(pwd, pwd_len, CE_UTF8)));
/* FIXME: we'll leak if the above fails in R */
SecKeychainItemFreeContent(NULL, pwd);
if (do_rm) {
status = SecKeychainItemDelete(kci);
chk_status(status, "delete");
} else if (new_pwd != R_NilValue) { /* set a new one */
const char *np = Rf_translateCharUTF8(STRING_ELT(new_pwd, 0));
status = SecKeychainItemModifyContent(kci, NULL, strlen(np), np);
chk_status(status, "modify");
}
UNPROTECT(1);
return res;
}
void omxComputeNumericDeriv::initFromFrontend(omxState *state, SEXP rObj)
{
super::initFromFrontend(state, rObj);
/*if (state->conListX.size()) {
mxThrow("%s: cannot proceed with constraints (%d constraints found)",
name, int(state->conListX.size()));
}*/
fitMat = omxNewMatrixFromSlot(rObj, state, "fitfunction");
SEXP slotValue;
Rf_protect(slotValue = R_do_slot(rObj, Rf_install("iterations")));
numIter = INTEGER(slotValue)[0];
if (numIter < 2) mxThrow("stepSize must be 2 or greater");
Rf_protect(slotValue = R_do_slot(rObj, Rf_install("parallel")));
parallel = Rf_asLogical(slotValue);
Rf_protect(slotValue = R_do_slot(rObj, Rf_install("checkGradient")));
checkGradient = Rf_asLogical(slotValue);
Rf_protect(slotValue = R_do_slot(rObj, Rf_install("verbose")));
verbose = Rf_asInteger(slotValue);
{
ProtectedSEXP Rhessian(R_do_slot(rObj, Rf_install("hessian")));
wantHessian = Rf_asLogical(Rhessian);
}
Rf_protect(slotValue = R_do_slot(rObj, Rf_install("stepSize")));
stepSize = GRADIENT_FUDGE_FACTOR(3.0) * REAL(slotValue)[0];
if (stepSize <= 0) mxThrow("stepSize must be positive");
knownHessian = NULL;
{
ScopedProtect(slotValue, R_do_slot(rObj, Rf_install("knownHessian")));
if (!Rf_isNull(slotValue)) {
knownHessian = REAL(slotValue);
SEXP dimnames;
ScopedProtect pdn(dimnames, Rf_getAttrib(slotValue, R_DimNamesSymbol));
{
SEXP names;
ScopedProtect p1(names, VECTOR_ELT(dimnames, 0));
{
int nlen = Rf_length(names);
khMap.assign(nlen, -1);
for (int nx=0; nx < nlen; ++nx) {
const char *vname = CHAR(STRING_ELT(names, nx));
for (int vx=0; vx < int(varGroup->vars.size()); ++vx) {
if (strEQ(vname, varGroup->vars[vx]->name)) {
khMap[nx] = vx;
if (verbose >= 1) mxLog("%s: knownHessian[%d] '%s' mapped to %d",
name, nx, vname, vx);
break;
}
}
}
}
}
}
}
numParams = 0;
totalProbeCount = 0;
numParams = 0;
recordDetail = true;
detail = 0;
}
void ifaGroup::import(SEXP Rlist)
{
SEXP argNames;
Rf_protect(argNames = Rf_getAttrib(Rlist, R_NamesSymbol));
if (Rf_length(Rlist) != Rf_length(argNames)) {
mxThrow("All list elements must be named");
}
std::vector<const char *> dataColNames;
paramRows = -1;
int pmatCols=-1;
int mips = 1;
int dataRows = 0;
SEXP Rmean=0, Rcov=0;
for (int ax=0; ax < Rf_length(Rlist); ++ax) {
const char *key = R_CHAR(STRING_ELT(argNames, ax));
SEXP slotValue = VECTOR_ELT(Rlist, ax);
if (strEQ(key, "spec")) {
importSpec(slotValue);
} else if (strEQ(key, "param")) {
if (!Rf_isReal(slotValue)) mxThrow("'param' must be a numeric matrix of item parameters");
param = REAL(slotValue);
getMatrixDims(slotValue, ¶mRows, &pmatCols);
SEXP dimnames;
Rf_protect(dimnames = Rf_getAttrib(slotValue, R_DimNamesSymbol));
if (!Rf_isNull(dimnames) && Rf_length(dimnames) == 2) {
SEXP names;
Rf_protect(names = VECTOR_ELT(dimnames, 0));
int nlen = Rf_length(names);
factorNames.resize(nlen);
for (int nx=0; nx < nlen; ++nx) {
factorNames[nx] = CHAR(STRING_ELT(names, nx));
}
Rf_protect(names = VECTOR_ELT(dimnames, 1));
nlen = Rf_length(names);
itemNames.resize(nlen);
for (int nx=0; nx < nlen; ++nx) {
itemNames[nx] = CHAR(STRING_ELT(names, nx));
}
}
} else if (strEQ(key, "mean")) {
Rmean = slotValue;
if (!Rf_isReal(slotValue)) mxThrow("'mean' must be a numeric vector or matrix");
mean = REAL(slotValue);
} else if (strEQ(key, "cov")) {
Rcov = slotValue;
if (!Rf_isReal(slotValue)) mxThrow("'cov' must be a numeric matrix");
cov = REAL(slotValue);
} else if (strEQ(key, "data")) {
Rdata = slotValue;
dataRows = Rf_length(VECTOR_ELT(Rdata, 0));
SEXP names;
Rf_protect(names = Rf_getAttrib(Rdata, R_NamesSymbol));
int nlen = Rf_length(names);
dataColNames.reserve(nlen);
for (int nx=0; nx < nlen; ++nx) {
dataColNames.push_back(CHAR(STRING_ELT(names, nx)));
}
Rf_protect(dataRowNames = Rf_getAttrib(Rdata, R_RowNamesSymbol));
} else if (strEQ(key, "weightColumn")) {
if (Rf_length(slotValue) != 1) {
mxThrow("You can only have one %s", key);
}
weightColumnName = CHAR(STRING_ELT(slotValue, 0));
} else if (strEQ(key, "freqColumn")) {
if (Rf_length(slotValue) != 1) {
mxThrow("You can only have one %s", key);
}
freqColumnName = CHAR(STRING_ELT(slotValue, 0));
} else if (strEQ(key, "qwidth")) {
qwidth = Rf_asReal(slotValue);
} else if (strEQ(key, "qpoints")) {
qpoints = Rf_asInteger(slotValue);
} else if (strEQ(key, "minItemsPerScore")) {
mips = Rf_asInteger(slotValue);
} else {
// ignore
}
}
learnMaxAbilities();
if (itemDims < (int) factorNames.size())
factorNames.resize(itemDims);
if (int(factorNames.size()) < itemDims) {
factorNames.reserve(itemDims);
const int SMALLBUF = 24;
char buf[SMALLBUF];
while (int(factorNames.size()) < itemDims) {
snprintf(buf, SMALLBUF, "s%d", int(factorNames.size()) + 1);
factorNames.push_back(CHAR(Rf_mkChar(buf)));
}
}
if (Rmean) {
if (Rf_isMatrix(Rmean)) {
int nrow, ncol;
getMatrixDims(Rmean, &nrow, &ncol);
if (!(nrow * ncol == itemDims && (nrow==1 || ncol==1))) {
mxThrow("mean must be a column or row matrix of length %d", itemDims);
}
} else {
if (Rf_length(Rmean) != itemDims) {
mxThrow("mean must be a vector of length %d", itemDims);
}
}
verifyFactorNames(Rmean, "mean");
}
if (Rcov) {
if (Rf_isMatrix(Rcov)) {
int nrow, ncol;
getMatrixDims(Rcov, &nrow, &ncol);
if (nrow != itemDims || ncol != itemDims) {
mxThrow("cov must be %dx%d matrix", itemDims, itemDims);
}
} else {
if (Rf_length(Rcov) != 1) {
mxThrow("cov must be %dx%d matrix", itemDims, itemDims);
}
}
verifyFactorNames(Rcov, "cov");
}
setLatentDistribution(mean, cov);
setMinItemsPerScore(mips);
if (numItems() != pmatCols) {
mxThrow("item matrix implies %d items but spec is length %d",
pmatCols, numItems());
}
if (Rdata) {
if (itemNames.size() == 0) mxThrow("Item matrix must have colnames");
for (int ix=0; ix < numItems(); ++ix) {
bool found=false;
for (int dc=0; dc < int(dataColNames.size()); ++dc) {
if (strEQ(itemNames[ix], dataColNames[dc])) {
SEXP col = VECTOR_ELT(Rdata, dc);
if (!Rf_isFactor(col)) {
if (TYPEOF(col) == INTSXP) {
mxThrow("Column '%s' is an integer but "
"not an ordered factor",
dataColNames[dc]);
} else {
mxThrow("Column '%s' is of type %s; expecting an "
"ordered factor (integer)",
dataColNames[dc], Rf_type2char(TYPEOF(col)));
}
}
dataColumns.push_back(INTEGER(col));
found=true;
break;
}
}
if (!found) {
mxThrow("Cannot find item '%s' in data", itemNames[ix]);
}
}
if (weightColumnName) {
for (int dc=0; dc < int(dataColNames.size()); ++dc) {
if (strEQ(weightColumnName, dataColNames[dc])) {
SEXP col = VECTOR_ELT(Rdata, dc);
if (TYPEOF(col) != REALSXP) {
mxThrow("Column '%s' is of type %s; expecting type numeric (double)",
dataColNames[dc], Rf_type2char(TYPEOF(col)));
}
rowWeight = REAL(col);
break;
}
}
if (!rowWeight) {
mxThrow("Cannot find weight column '%s'", weightColumnName);
}
}
if (freqColumnName) {
for (int dc=0; dc < int(dataColNames.size()); ++dc) {
if (strEQ(freqColumnName, dataColNames[dc])) {
SEXP col = VECTOR_ELT(Rdata, dc);
if (TYPEOF(col) != INTSXP) {
mxThrow("Column '%s' is of type %s; expecting type integer",
dataColNames[dc], Rf_type2char(TYPEOF(col)));
}
rowFreq = INTEGER(col);
break;
}
}
if (!rowFreq) {
mxThrow("Cannot find frequency column '%s'", freqColumnName);
}
}
rowMap.reserve(dataRows);
for (int rx=0; rx < dataRows; ++rx) rowMap.push_back(rx);
}
Eigen::Map< Eigen::ArrayXXd > Eparam(param, paramRows, numItems());
Eigen::Map< Eigen::VectorXd > meanVec(mean, itemDims);
Eigen::Map< Eigen::MatrixXd > covMat(cov, itemDims, itemDims);
quad.setStructure(qwidth, qpoints, Eparam, meanVec, covMat);
if (paramRows < impliedParamRows) {
mxThrow("At least %d rows are required in the item parameter matrix, only %d found",
impliedParamRows, paramRows);
}
quad.refresh(meanVec, covMat);
}
void omxInitExpectationBA81(omxExpectation* oo) {
omxState* currentState = oo->currentState;
SEXP rObj = oo->rObj;
SEXP tmp;
if(OMX_DEBUG) {
mxLog("Initializing %s.", oo->name);
}
if (!Glibrpf_model) {
#if USE_EXTERNAL_LIBRPF
get_librpf_t get_librpf = (get_librpf_t) R_GetCCallable("rpf", "get_librpf_model_GPL");
(*get_librpf)(LIBIFA_RPF_API_VERSION, &Glibrpf_numModels, &Glibrpf_model);
#else
// if linking against included source code
Glibrpf_numModels = librpf_numModels;
Glibrpf_model = librpf_model;
#endif
}
BA81Expect *state = new BA81Expect;
// These two constants should be as identical as possible
state->name = oo->name;
if (0) {
state->LogLargestDouble = 0.0;
state->LargestDouble = 1.0;
} else {
state->LogLargestDouble = log(std::numeric_limits<double>::max()) - 1;
state->LargestDouble = exp(state->LogLargestDouble);
ba81NormalQuad &quad = state->getQuad();
quad.setOne(state->LargestDouble);
}
state->expectedUsed = false;
state->estLatentMean = NULL;
state->estLatentCov = NULL;
state->type = EXPECTATION_OBSERVED;
state->itemParam = NULL;
state->EitemParam = NULL;
state->itemParamVersion = 0;
state->latentParamVersion = 0;
oo->argStruct = (void*) state;
{ScopedProtect p1(tmp, R_do_slot(rObj, Rf_install("data")));
state->data = omxDataLookupFromState(tmp, currentState);
}
if (strcmp(omxDataType(state->data), "raw") != 0) {
omxRaiseErrorf("%s unable to handle data type %s", oo->name, omxDataType(state->data));
return;
}
{ScopedProtect p1(tmp, R_do_slot(rObj, Rf_install("verbose")));
state->verbose = Rf_asInteger(tmp);
}
int targetQpoints;
{ScopedProtect p1(tmp, R_do_slot(rObj, Rf_install("qpoints")));
targetQpoints = Rf_asInteger(tmp);
}
{ScopedProtect p1(tmp, R_do_slot(rObj, Rf_install("qwidth")));
state->grp.setGridFineness(Rf_asReal(tmp), targetQpoints);
}
{ScopedProtect p1(tmp, R_do_slot(rObj, Rf_install("ItemSpec")));
state->grp.importSpec(tmp);
if (state->verbose >= 2) mxLog("%s: found %d item specs", oo->name, state->numItems());
}
state->_latentMeanOut = omxNewMatrixFromSlot(rObj, currentState, "mean");
state->_latentCovOut = omxNewMatrixFromSlot(rObj, currentState, "cov");
state->itemParam = omxNewMatrixFromSlot(rObj, currentState, "item");
state->grp.param = state->itemParam->data; // algebra not allowed yet TODO
const int numItems = state->itemParam->cols;
if (state->numItems() != numItems) {
omxRaiseErrorf("ItemSpec length %d must match the number of item columns (%d)",
state->numItems(), numItems);
return;
}
if (state->itemParam->rows != state->grp.impliedParamRows) {
omxRaiseErrorf("item matrix must have %d rows", state->grp.impliedParamRows);
return;
}
state->grp.paramRows = state->itemParam->rows;
// for algebra item param, will need to defer until later?
state->grp.learnMaxAbilities();
int maxAbilities = state->grp.itemDims;
state->grp.setFactorNames(state->itemParam->rownames);
{
ProtectedSEXP tmp2(R_do_slot(rObj, Rf_install(".detectIndependence")));
state->grp.detectIndependence = Rf_asLogical(tmp2);
}
{ScopedProtect p1(tmp, R_do_slot(rObj, Rf_install("EstepItem")));
if (!Rf_isNull(tmp)) {
int rows, cols;
getMatrixDims(tmp, &rows, &cols);
if (rows != state->itemParam->rows || cols != state->itemParam->cols) {
Rf_error("EstepItem must have the same dimensions as the item MxMatrix");
}
state->EitemParam = REAL(tmp);
}
}
oo->computeFun = ba81compute;
oo->setVarGroup = ignoreSetVarGroup;
oo->destructFun = ba81Destroy;
oo->populateAttrFun = ba81PopulateAttributes;
oo->componentFun = getComponent;
oo->canDuplicate = false;
// TODO: Exactly identical rows do not contribute any information.
// The sorting algorithm ought to remove them so we get better cache behavior.
// The following summary stats would be cheaper to calculate too.
omxData *data = state->data;
if (data->hasDefinitionVariables()) Rf_error("%s: not implemented yet", oo->name);
std::vector<int> &rowMap = state->grp.rowMap;
int weightCol;
{ScopedProtect p1(tmp, R_do_slot(rObj, Rf_install("weightColumn")));
weightCol = INTEGER(tmp)[0];
}
if (weightCol == NA_INTEGER) {
// Should rowMap be part of omxData? This is essentially a
// generic compression step that shouldn't be specific to IFA models.
state->grp.rowWeight = (double*) R_alloc(data->rows, sizeof(double));
rowMap.resize(data->rows);
int numUnique = 0;
for (int rx=0; rx < data->rows; ) {
int rw = 1;
state->grp.rowWeight[numUnique] = rw;
rowMap[numUnique] = rx;
rx += rw;
++numUnique;
}
rowMap.resize(numUnique);
state->weightSum = state->data->rows;
}
else {
if (omxDataColumnIsFactor(data, weightCol)) {
omxRaiseErrorf("%s: weightColumn %d is a factor", oo->name, 1 + weightCol);
return;
}
state->grp.rowWeight = omxDoubleDataColumn(data, weightCol);
state->weightSum = 0;
for (int rx=0; rx < data->rows; ++rx) { state->weightSum += state->grp.rowWeight[rx]; }
rowMap.resize(data->rows);
for (size_t rx=0; rx < rowMap.size(); ++rx) {
rowMap[rx] = rx;
}
}
// complain about non-integral rowWeights (EAP can't work) TODO
auto colMap = oo->getDataColumns();
for (int cx = 0; cx < numItems; cx++) {
int *col = omxIntDataColumnUnsafe(data, colMap[cx]);
state->grp.dataColumns.push_back(col);
}
// sanity check data
for (int cx = 0; cx < numItems; cx++) {
if (!omxDataColumnIsFactor(data, colMap[cx])) {
data->omxPrintData("diagnostic", 3);
omxRaiseErrorf("%s: column %d is not a factor", oo->name, int(1 + colMap[cx]));
return;
}
}
// TODO the max outcome should be available from omxData
for (int rx=0; rx < data->rows; rx++) {
int cols = 0;
for (int cx = 0; cx < numItems; cx++) {
const int *col = state->grp.dataColumns[cx];
int pick = col[rx];
if (pick == NA_INTEGER) continue;
++cols;
const int no = state->grp.itemOutcomes[cx];
if (pick > no) {
Rf_error("Data for item '%s' has at least %d outcomes, not %d",
state->itemParam->colnames[cx], pick, no);
}
}
if (cols == 0) {
Rf_error("Row %d has all NAs", 1+rx);
}
}
if (state->_latentMeanOut && state->_latentMeanOut->rows * state->_latentMeanOut->cols != maxAbilities) {
Rf_error("The mean matrix '%s' must be a row or column vector of size %d",
state->_latentMeanOut->name(), maxAbilities);
}
if (state->_latentCovOut && (state->_latentCovOut->rows != maxAbilities ||
state->_latentCovOut->cols != maxAbilities)) {
Rf_error("The cov matrix '%s' must be %dx%d",
state->_latentCovOut->name(), maxAbilities, maxAbilities);
}
state->grp.setLatentDistribution(state->_latentMeanOut? state->_latentMeanOut->data : NULL,
state->_latentCovOut? state->_latentCovOut->data : NULL);
{
EigenArrayAdaptor Eparam(state->itemParam);
Eigen::Map< Eigen::VectorXd > meanVec(state->grp.mean, maxAbilities);
Eigen::Map< Eigen::MatrixXd > covMat(state->grp.cov, maxAbilities, maxAbilities);
state->grp.quad.setStructure(state->grp.qwidth, state->grp.qpoints,
Eparam, meanVec, covMat);
}
{ScopedProtect p1(tmp, R_do_slot(rObj, Rf_install("minItemsPerScore")));
state->grp.setMinItemsPerScore(Rf_asInteger(tmp));
}
state->grp.buildRowSkip();
if (isErrorRaised()) return;
{ScopedProtect p1(tmp, R_do_slot(rObj, Rf_install("debugInternal")));
state->debugInternal = Rf_asLogical(tmp);
}
state->ElatentVersion = 0;
if (state->_latentMeanOut) {
state->estLatentMean = omxInitMatrix(maxAbilities, 1, TRUE, currentState);
omxCopyMatrix(state->estLatentMean, state->_latentMeanOut); // rename matrices TODO
}
if (state->_latentCovOut) {
state->estLatentCov = omxInitMatrix(maxAbilities, maxAbilities, TRUE, currentState);
omxCopyMatrix(state->estLatentCov, state->_latentCovOut);
}
}
void omxInitFIMLFitFunction(omxFitFunction* off)
{
if(OMX_DEBUG) {
mxLog("Initializing FIML fit function function.");
}
off->canDuplicate = TRUE;
SEXP rObj = off->rObj;
int numOrdinal = 0, numContinuous = 0;
omxMatrix *cov, *means;
omxFIMLFitFunction *newObj = new omxFIMLFitFunction;
omxExpectation* expectation = off->expectation;
if(expectation == NULL) {
omxRaiseError("FIML cannot fit without model expectations.");
return;
}
cov = omxGetExpectationComponent(expectation, "cov");
if(cov == NULL) {
omxRaiseError("No covariance expectation in FIML evaluation.");
return;
}
means = omxGetExpectationComponent(expectation, "means");
if(OMX_DEBUG) {
mxLog("FIML Initialization Completed.");
}
newObj->cov = cov;
newObj->means = means;
newObj->smallMeans = NULL;
newObj->ordMeans = NULL;
newObj->contRow = NULL;
newObj->ordRow = NULL;
newObj->ordCov = NULL;
newObj->ordContCov = NULL;
newObj->halfCov = NULL;
newObj->reduceCov = NULL;
off->computeFun = CallFIMLFitFunction;
newObj->corList = NULL;
newObj->weights = NULL;
newObj->SingleIterFn = omxFIMLSingleIterationJoint;
off->destructFun = omxDestroyFIMLFitFunction;
off->populateAttrFun = omxPopulateFIMLAttributes;
if(OMX_DEBUG) {
mxLog("Accessing data source.");
}
newObj->data = off->expectation->data;
if(OMX_DEBUG) {
mxLog("Accessing row likelihood option.");
}
newObj->returnRowLikelihoods = Rf_asInteger(R_do_slot(rObj, Rf_install("vector")));
newObj->rowLikelihoods = omxInitMatrix(newObj->data->rows, 1, TRUE, off->matrix->currentState);
newObj->rowLogLikelihoods = omxInitMatrix(newObj->data->rows, 1, TRUE, off->matrix->currentState);
if(OMX_DEBUG) {
mxLog("Accessing row likelihood population option.");
}
newObj->populateRowDiagnostics = Rf_asInteger(R_do_slot(rObj, Rf_install("rowDiagnostics")));
if(OMX_DEBUG) {
mxLog("Accessing variable mapping structure.");
}
newObj->dataColumns = off->expectation->dataColumns;
if(OMX_DEBUG) {
mxLog("Accessing Threshold matrix.");
}
numOrdinal = off->expectation->numOrdinal;
numContinuous = newObj->dataColumns->cols - numOrdinal;
omxSetContiguousDataColumns(&(newObj->contiguous), newObj->data, newObj->dataColumns);
/* Temporary storage for calculation */
int covCols = newObj->cov->cols;
if(OMX_DEBUG){mxLog("Number of columns found is %d", covCols);}
// int ordCols = omxDataNumFactor(newObj->data); // Unneeded, since we don't use it.
// int contCols = omxDataNumNumeric(newObj->data);
newObj->smallRow = omxInitMatrix(1, covCols, TRUE, off->matrix->currentState);
newObj->smallCov = omxInitMatrix(covCols, covCols, TRUE, off->matrix->currentState);
newObj->RCX = omxInitMatrix(1, covCols, TRUE, off->matrix->currentState);
// newObj->zeros = omxInitMatrix(1, newObj->cov->cols, TRUE, off->matrix->currentState);
omxCopyMatrix(newObj->smallCov, newObj->cov); // Will keep its aliased state from here on.
if (means) {
newObj->smallMeans = omxInitMatrix(covCols, 1, TRUE, off->matrix->currentState);
omxCopyMatrix(newObj->smallMeans, newObj->means);
newObj->ordMeans = omxInitMatrix(covCols, 1, TRUE, off->matrix->currentState);
omxCopyMatrix(newObj->ordMeans, newObj->means);
}
newObj->contRow = omxInitMatrix(covCols, 1, TRUE, off->matrix->currentState);
omxCopyMatrix(newObj->contRow, newObj->smallRow );
newObj->ordCov = omxInitMatrix(covCols, covCols, TRUE, off->matrix->currentState);
omxCopyMatrix(newObj->ordCov, newObj->cov);
newObj->ordRow = omxInitMatrix(covCols, 1, TRUE, off->matrix->currentState);
omxCopyMatrix(newObj->ordRow, newObj->smallRow );
newObj->Infin = (int*) R_alloc(covCols, sizeof(int));
off->argStruct = (void*)newObj;
//if (strEQ(expectation->expType, "MxExpectationStateSpace")) {
// newObj->SingleIterFn = omxFIMLSingleIteration; // remove this TODO
//}
if(numOrdinal > 0 && numContinuous <= 0) {
if(OMX_DEBUG) {
mxLog("Ordinal Data detected. Using Ordinal FIML.");
}
newObj->weights = (double*) R_alloc(covCols, sizeof(double));
newObj->corList = (double*) R_alloc(covCols * (covCols + 1) / 2, sizeof(double));
newObj->smallCor = (double*) R_alloc(covCols * (covCols + 1) / 2, sizeof(double));
newObj->lThresh = (double*) R_alloc(covCols, sizeof(double));
newObj->uThresh = (double*) R_alloc(covCols, sizeof(double));
} else if(numOrdinal > 0) {
if(OMX_DEBUG) {
mxLog("Ordinal and Continuous Data detected. Using Joint Ordinal/Continuous FIML.");
}
newObj->weights = (double*) R_alloc(covCols, sizeof(double));
newObj->ordContCov = omxInitMatrix(covCols, covCols, TRUE, off->matrix->currentState);
newObj->halfCov = omxInitMatrix(covCols, covCols, TRUE, off->matrix->currentState);
newObj->reduceCov = omxInitMatrix(covCols, covCols, TRUE, off->matrix->currentState);
omxCopyMatrix(newObj->ordContCov, newObj->cov);
newObj->corList = (double*) R_alloc(covCols * (covCols + 1) / 2, sizeof(double));
newObj->lThresh = (double*) R_alloc(covCols, sizeof(double));
newObj->uThresh = (double*) R_alloc(covCols, sizeof(double));
}
}
SEXP jsClientLib_jsclient_device_resize_(SEXP deviceSEXP, SEXP widthSEXP, SEXP heightSEXP, SEXP replaySEXP) {
jsclient_device_resize_( Rf_asInteger( deviceSEXP ), Rf_asInteger( widthSEXP ), Rf_asInteger( heightSEXP ), Rf_asInteger( replaySEXP ));
return R_NilValue;
}
SEXP ocl_collect_call(SEXP octx, SEXP wait) {
SEXP res = R_NilValue;
ocl_call_context_t *occ;
int on;
cl_int err;
if (!Rf_inherits(octx, "clCallContext"))
Rf_error("Invalid call context");
occ = (ocl_call_context_t*) R_ExternalPtrAddr(octx);
if (!occ || occ->finished)
Rf_error("The call results have already been collected, they cannot be retrieved twice");
if (Rf_asInteger(wait) == 0 && occ->event) {
cl_int status;
if ((err = clGetEventInfo(occ->event, CL_EVENT_COMMAND_EXECUTION_STATUS, sizeof(status), &status, NULL)) != CL_SUCCESS)
Rf_error("OpenCL error 0x%x while querying event object for the supplied context", (int) err);
if (status < 0)
Rf_error("Asynchronous call failed with error code 0x%x", (int) -status);
if (status != CL_COMPLETE)
return R_NilValue;
}
clFinish(occ->commands);
occ->finished = 1;
/* we can release input memory objects now */
if (occ->mem_objects) {
arg_free(occ->mem_objects, (afin_t) clReleaseMemObject);
occ->mem_objects = 0;
}
if (occ->float_args) {
arg_free(occ->float_args, 0);
occ->float_args = 0;
}
on = occ->on;
res = occ->ftres ? Rf_allocVector(RAWSXP, on * sizeof(float)) : Rf_allocVector(REALSXP, on);
if (occ->ftype == FT_SINGLE) {
if (occ->ftres) {
if ((err = clEnqueueReadBuffer( occ->commands, occ->output, CL_TRUE, 0, sizeof(float) * on, RAW(res), 0, NULL, NULL )) != CL_SUCCESS)
Rf_error("Unable to transfer result vector (%d float elements, oclError %d)", on, err);
PROTECT(res);
Rf_setAttrib(res, R_ClassSymbol, mkString("clFloat"));
UNPROTECT(1);
} else {
/* float - need a temporary buffer */
float *fr = (float*) malloc(sizeof(float) * on);
double *r = REAL(res);
int i;
if (!fr)
Rf_error("unable to allocate memory for temporary single-precision output buffer");
occ->float_out = fr;
if ((err = clEnqueueReadBuffer( occ->commands, occ->output, CL_TRUE, 0, sizeof(float) * on, fr, 0, NULL, NULL )) != CL_SUCCESS)
Rf_error("Unable to transfer result vector (%d float elements, oclError %d)", on, err);
for (i = 0; i < on; i++)
r[i] = fr[i];
}
} else if ((err = clEnqueueReadBuffer( occ->commands, occ->output, CL_TRUE, 0, sizeof(double) * on, REAL(res), 0, NULL, NULL )) != CL_SUCCESS)
Rf_error("Unable to transfer result vector (%d double elements, oclError %d)", on, err);
ocl_call_context_fin(octx);
return res;
}
/* .External */
SEXP ocl_call(SEXP args) {
struct arg_chain *float_args = 0;
ocl_call_context_t *occ;
int on, an = 0, ftype = FT_DOUBLE, ftsize, ftres, async;
SEXP ker = CADR(args), olen, arg, res, octx, dimVec;
cl_kernel kernel = getKernel(ker);
cl_context context;
cl_command_queue commands;
cl_device_id device_id = getDeviceID(getAttrib(ker, Rf_install("device")));
cl_mem output;
cl_int err;
size_t wdims[3] = {0, 0, 0};
int wdim = 1;
if (clGetKernelInfo(kernel, CL_KERNEL_CONTEXT, sizeof(context), &context, NULL) != CL_SUCCESS || !context)
Rf_error("cannot obtain kernel context via clGetKernelInfo");
args = CDDR(args);
res = Rf_getAttrib(ker, install("precision"));
if (TYPEOF(res) == STRSXP && LENGTH(res) == 1 && CHAR(STRING_ELT(res, 0))[0] != 'd')
ftype = FT_SINGLE;
ftsize = (ftype == FT_DOUBLE) ? sizeof(double) : sizeof(float);
olen = CAR(args); /* size */
args = CDR(args);
on = Rf_asInteger(olen);
if (on < 0)
Rf_error("invalid output length");
ftres = (Rf_asInteger(CAR(args)) == 1) ? 1 : 0; /* native.result */
if (ftype != FT_SINGLE) ftres = 0;
args = CDR(args);
async = (Rf_asInteger(CAR(args)) == 1) ? 0 : 1; /* wait */
args = CDR(args);
dimVec = coerceVector(CAR(args), INTSXP); /* dim */
wdim = LENGTH(dimVec);
if (wdim > 3)
Rf_error("OpenCL standard only supports up to three work item dimensions - use index vectors for higher dimensions");
if (wdim) {
int i; /* we don't use memcpy in case int and size_t are different */
for (i = 0; i < wdim; i++)
wdims[i] = INTEGER(dimVec)[i];
}
if (wdim < 1 || wdims[0] < 1 || (wdim > 1 && wdims[1] < 1) || (wdim > 2 && wdims[2] < 1))
Rf_error("invalid dimensions - muse be a numeric vector with positive values");
args = CDR(args);
occ = (ocl_call_context_t*) calloc(1, sizeof(ocl_call_context_t));
if (!occ) Rf_error("unable to allocate ocl_call context");
octx = PROTECT(R_MakeExternalPtr(occ, R_NilValue, R_NilValue));
R_RegisterCFinalizerEx(octx, ocl_call_context_fin, TRUE);
occ->output = output = clCreateBuffer(context, CL_MEM_WRITE_ONLY, ftsize * on, NULL, &err);
if (!output)
Rf_error("failed to create output buffer of %d elements via clCreateBuffer (%d)", on, err);
if (clSetKernelArg(kernel, an++, sizeof(cl_mem), &output) != CL_SUCCESS)
Rf_error("failed to set first kernel argument as output in clSetKernelArg");
if (clSetKernelArg(kernel, an++, sizeof(on), &on) != CL_SUCCESS)
Rf_error("failed to set second kernel argument as output length in clSetKernelArg");
occ->commands = commands = clCreateCommandQueue(context, device_id, 0, &err);
if (!commands)
ocl_err("clCreateCommandQueue");
if (ftype == FT_SINGLE) /* need conversions, create floats buffer */
occ->float_args = float_args = arg_alloc(0, 32);
while ((arg = CAR(args)) != R_NilValue) {
int n, ndiv = 1;
void *ptr;
size_t al;
switch (TYPEOF(arg)) {
case REALSXP:
if (ftype == FT_SINGLE) {
int i;
float *f;
double *d = REAL(arg);
n = LENGTH(arg);
f = (float*) malloc(sizeof(float) * n);
if (!f)
Rf_error("unable to allocate temporary single-precision memory for conversion from a double-precision argument vector of length %d", n);
for (i = 0; i < n; i++) f[i] = d[i];
ptr = f;
al = sizeof(float);
arg_add(float_args, ptr);
} else {
ptr = REAL(arg);
al = sizeof(double);
}
break;
case INTSXP:
ptr = INTEGER(arg);
al = sizeof(int);
break;
case LGLSXP:
ptr = LOGICAL(arg);
al = sizeof(int);
break;
case RAWSXP:
if (inherits(arg, "clFloat")) {
ptr = RAW(arg);
ndiv = al = sizeof(float);
break;
}
default:
Rf_error("only numeric or logical kernel arguments are supported");
/* no-ops but needed to make the compiler happy */
ptr = 0;
al = 0;
}
n = LENGTH(arg);
if (ndiv != 1) n /= ndiv;
if (n == 1) {/* scalar */
if (clSetKernelArg(kernel, an++, al, ptr) != CL_SUCCESS)
Rf_error("Failed to set scalar kernel argument %d (size=%d)", an, al);
} else {
cl_mem input = clCreateBuffer(context, CL_MEM_READ_ONLY | CL_MEM_USE_HOST_PTR, al * n, ptr, &err);
if (!input)
Rf_error("Unable to create buffer (%d elements, %d bytes each) for vector argument %d (oclError %d)", n, al, an, err);
if (!occ->mem_objects)
occ->mem_objects = arg_alloc(0, 32);
arg_add(occ->mem_objects, input);
#if 0 /* we used this before CL_MEM_USE_HOST_PTR */
if (clEnqueueWriteBuffer(commands, input, CL_TRUE, 0, al * n, ptr, 0, NULL, NULL) != CL_SUCCESS)
Rf_error("Failed to transfer data (%d elements) for vector argument %d", n, an);
#endif
if (clSetKernelArg(kernel, an++, sizeof(cl_mem), &input) != CL_SUCCESS)
Rf_error("Failed to set vector kernel argument %d (size=%d, length=%d)", an, al, n);
/* clReleaseMemObject(input); */
}
args = CDR(args);
}
if (clEnqueueNDRangeKernel(commands, kernel, wdim, NULL, wdims, NULL, 0, NULL, async ? &occ->event : NULL) != CL_SUCCESS)
Rf_error("Error during kernel execution");
if (async) { /* asynchronous call -> get out and return the context */
#if USE_OCL_COMPLETE_CALLBACK
clSetEventCallback(occ->event, CL_COMPLETE, ocl_complete_callback, occ);
#endif
clFlush(commands); /* the specs don't guarantee execution unless clFlush is called */
occ->ftres = ftres;
occ->ftype = ftype;
occ->on = on;
Rf_setAttrib(octx, R_ClassSymbol, mkString("clCallContext"));
UNPROTECT(1);
return octx;
}
clFinish(commands);
occ->finished = 1;
/* we can release input memory objects now */
if (occ->mem_objects) {
arg_free(occ->mem_objects, (afin_t) clReleaseMemObject);
occ->mem_objects = 0;
}
if (float_args) {
arg_free(float_args, 0);
float_args = occ->float_args = 0;
}
res = ftres ? Rf_allocVector(RAWSXP, on * sizeof(float)) : Rf_allocVector(REALSXP, on);
if (ftype == FT_SINGLE) {
if (ftres) {
if ((err = clEnqueueReadBuffer( commands, output, CL_TRUE, 0, sizeof(float) * on, RAW(res), 0, NULL, NULL )) != CL_SUCCESS)
Rf_error("Unable to transfer result vector (%d float elements, oclError %d)", on, err);
PROTECT(res);
Rf_setAttrib(res, R_ClassSymbol, mkString("clFloat"));
UNPROTECT(1);
} else {
/* float - need a temporary buffer */
float *fr = (float*) malloc(sizeof(float) * on);
double *r = REAL(res);
int i;
if (!fr)
Rf_error("unable to allocate memory for temporary single-precision output buffer");
occ->float_out = fr;
if ((err = clEnqueueReadBuffer( commands, output, CL_TRUE, 0, sizeof(float) * on, fr, 0, NULL, NULL )) != CL_SUCCESS)
Rf_error("Unable to transfer result vector (%d float elements, oclError %d)", on, err);
for (i = 0; i < on; i++)
r[i] = fr[i];
}
} else if ((err = clEnqueueReadBuffer( commands, output, CL_TRUE, 0, sizeof(double) * on, REAL(res), 0, NULL, NULL )) != CL_SUCCESS)
Rf_error("Unable to transfer result vector (%d double elements, oclError %d)", on, err);
ocl_call_context_fin(octx);
UNPROTECT(1);
return res;
}
SEXP jsClientLib_jsclient_device_(SEXP nameSEXP, SEXP backgroundSEXP, SEXP widthSEXP, SEXP heightSEXP, SEXP pointsizeSEXP) {
const char *name = CHAR(STRING_ELT(nameSEXP, 0));
const char *background = CHAR(STRING_ELT(backgroundSEXP, 0));
int rslt = jsclient_device_( name, background, Rf_asInteger( widthSEXP ), Rf_asInteger( heightSEXP ), Rf_asInteger( pointsizeSEXP ));
return Rf_ScalarReal(rslt);
}
