コード例 #1
0
ファイル: RBGL.hpp プロジェクト: martinjreed/reedgraph
 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);
         }
     }
 }
コード例 #2
0
ファイル: RBGL.hpp プロジェクト: martinjreed/reedgraph
 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);
     }
 }
コード例 #3
0
ファイル: omxAlgebraFitFunction.cpp プロジェクト: cran/OpenMx
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;
}
コード例 #4
0
ファイル: glue.cpp プロジェクト: jpritikin/rpf
static SEXP setNumberOfCores(SEXP num)
{
	omxManageProtectInsanity mpi;
#if defined(_OPENMP)
	GlobalNumberOfCores = Rf_asInteger(num);
#endif
	return num;
}
コード例 #5
0
ファイル: ocl.c プロジェクト: mprymek/OpenCL
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);
}
コード例 #6
0
ファイル: ocl.c プロジェクト: cran/OpenCL
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);
}
コード例 #7
0
 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);
   }
 }
コード例 #8
0
ファイル: credis.c プロジェクト: nandakishorkoka/rediscc
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;
}
コード例 #9
0
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;
}
コード例 #10
0
ファイル: omxFitFunction.cpp プロジェクト: falkcarl/OpenMx
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;
}
コード例 #11
0
ファイル: MarkovFF.cpp プロジェクト: OpenMx/OpenMx
	// 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");
	}
コード例 #12
0
ファイル: tools.c プロジェクト: cran/OpenCL
/* 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;
}
コード例 #13
0
ファイル: fitMultigroup.cpp プロジェクト: OpenMx/OpenMx
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;
		}
	}
}
コード例 #14
0
ファイル: driver.c プロジェクト: brezniczky/audio
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;
}
コード例 #15
0
ファイル: MarkovExpectation.cpp プロジェクト: cran/OpenMx
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);
	}
}
コード例 #16
0
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")));
}
コード例 #17
0
ファイル: rlibjson.c プロジェクト: wyngit/RJSONIO
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);
}
コード例 #18
0
ファイル: glue.cpp プロジェクト: jpritikin/rpf
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;
}
コード例 #19
0
ファイル: javaGD.c プロジェクト: carrot-garden/rp_rj-core
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;
}
コード例 #20
0
ファイル: Rinternals.c プロジェクト: anukat2015/fastr
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);
}
コード例 #21
0
Rconnection get_connection(SEXP con) {
  if (!Rf_inherits(con, "connection"))
    Rcpp::stop("invalid connection");
  return getConnection(Rf_asInteger(con));
}
コード例 #22
0
ファイル: mac.c プロジェクト: hirenj/keychain
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;
}
コード例 #23
0
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;
}
コード例 #24
0
ファイル: ba81quad.cpp プロジェクト: OpenMx/OpenMx
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, &paramRows, &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);
}
コード例 #25
0
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);
	}
}
コード例 #26
0
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));
    }
}
コード例 #27
0
ファイル: Wrapper.cpp プロジェクト: sdllc/jsclientlib
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;
}
コード例 #28
0
ファイル: ocl.c プロジェクト: cran/OpenCL
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;
}
コード例 #29
0
ファイル: ocl.c プロジェクト: cran/OpenCL
/* .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;
}
コード例 #30
0
ファイル: Wrapper.cpp プロジェクト: sdllc/jsclientlib
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);
}