/** Get the symmetric closure of a binary relation
*
* @param x square logical matrix
* @return square logical matrix
*
* @version 0.2 (Marek Gagolewski)
*/
SEXP rel_closure_symmetric(SEXP x)
{
x = prepare_arg_logical_square_matrix(x, "R");
SEXP dim = Rf_getAttrib(x, R_DimSymbol);
R_len_t n = INTEGER(dim)[0];
int* xp = INTEGER(x);
SEXP y = Rf_allocVector(LGLSXP, n*n);
int* yp = INTEGER(y);
Rf_setAttrib(y, R_DimSymbol, dim);
Rf_setAttrib(y, R_DimNamesSymbol, Rf_getAttrib(x, R_DimNamesSymbol)); // preserve dimnames
for (R_len_t i=0; i<n*n; ++i) {
if (xp[i] == NA_LOGICAL)
Rf_error(MSG__ARG_EXPECTED_NOT_NA, "R"); // missing values are not allowed
yp[i] = xp[i];
}
for (R_len_t i=0; i<n-1; ++i) {
for (R_len_t j=i+1; j<n; ++j) {
if (yp[i+n*j] && !yp[j+n*i])
yp[j+n*i] = TRUE;
else if (yp[j+n*i] && !yp[i+n*j])
yp[i+n*j] = TRUE;
}
}
return y;
}
void omxPopulateFIMLAttributes(omxFitFunction *off, SEXP algebra) {
if(OMX_DEBUG) { mxLog("Populating FIML Attributes."); }
omxFIMLFitFunction *argStruct = ((omxFIMLFitFunction*)off->argStruct);
SEXP expCovExt, expMeanExt, rowLikelihoodsExt;
omxMatrix *expCovInt, *expMeanInt;
expCovInt = argStruct->cov;
expMeanInt = argStruct->means;
Rf_protect(expCovExt = Rf_allocMatrix(REALSXP, expCovInt->rows, expCovInt->cols));
for(int row = 0; row < expCovInt->rows; row++)
for(int col = 0; col < expCovInt->cols; col++)
REAL(expCovExt)[col * expCovInt->rows + row] =
omxMatrixElement(expCovInt, row, col);
if (expMeanInt != NULL && expMeanInt->rows > 0 && expMeanInt->cols > 0) {
Rf_protect(expMeanExt = Rf_allocMatrix(REALSXP, expMeanInt->rows, expMeanInt->cols));
for(int row = 0; row < expMeanInt->rows; row++)
for(int col = 0; col < expMeanInt->cols; col++)
REAL(expMeanExt)[col * expMeanInt->rows + row] =
omxMatrixElement(expMeanInt, row, col);
} else {
Rf_protect(expMeanExt = Rf_allocMatrix(REALSXP, 0, 0));
}
Rf_setAttrib(algebra, Rf_install("expCov"), expCovExt);
Rf_setAttrib(algebra, Rf_install("expMean"), expMeanExt);
if(argStruct->populateRowDiagnostics){
omxMatrix *rowLikelihoodsInt = argStruct->rowLikelihoods;
Rf_protect(rowLikelihoodsExt = Rf_allocVector(REALSXP, rowLikelihoodsInt->rows));
for(int row = 0; row < rowLikelihoodsInt->rows; row++)
REAL(rowLikelihoodsExt)[row] = omxMatrixElement(rowLikelihoodsInt, row, 0);
Rf_setAttrib(algebra, Rf_install("likelihoods"), rowLikelihoodsExt);
}
}
/** Get the transitive closure of a binary relation
*
* @param x square logical matrix
* @return square logical matrix
*
* @version 0.2 (Marek Gagolewski)
*/
SEXP rel_closure_transitive(SEXP x)
{
x = prepare_arg_logical_square_matrix(x, "R");
SEXP dim = Rf_getAttrib(x, R_DimSymbol);
R_len_t n = INTEGER(dim)[0];
int* xp = INTEGER(x);
SEXP y = Rf_allocVector(LGLSXP, n*n);
int* yp = INTEGER(y);
Rf_setAttrib(y, R_DimSymbol, dim);
Rf_setAttrib(y, R_DimNamesSymbol, Rf_getAttrib(x, R_DimNamesSymbol)); // preserve dimnames
for (R_len_t i=0; i<n*n; ++i) {
if (xp[i] == NA_LOGICAL)
Rf_error(MSG__ARG_EXPECTED_NOT_NA, "R"); // missing values are not allowed
yp[i] = xp[i];
}
for (R_len_t k=0; k<n; ++k) { // Warshall's algorithm
for (R_len_t i=0; i<n; ++i) {
for (R_len_t j=0; j<n; ++j) {
yp[i+n*j] = (yp[i+n*j] || (yp[i+n*k] && yp[k+n*j]));
}
}
}
return y;
}
SEXP jr_data_frame(jl_value_t *tt)
{
SEXP ans = R_NilValue;
SEXP rnames, d;
jl_array_t *names = (jl_array_t *) jl_get_nth_field(jl_get_nth_field(tt, 1), 1);
jl_array_t *columns = (jl_array_t *) jl_get_nth_field(tt, 0);
JL_GC_PUSH2(&names, &columns);
size_t n = jl_array_len(jl_get_nth_field(jl_arrayref(columns, 0), 0));
size_t m = jl_array_len(columns);
PROTECT(ans = Rf_allocVector(VECSXP, m));
PROTECT(rnames = Rf_allocVector(STRSXP, m));
for(size_t i=0; i<m; i++)
{
SET_VECTOR_ELT(ans, i, jr_data_array((jl_value_t *) jl_arrayref(columns, i)));
SET_STRING_ELT(rnames, i, Rf_mkChar(((jl_sym_t *) jl_arrayref(names, i))->name));
}
Rf_setAttrib(ans, R_NamesSymbol, rnames);
Rf_setAttrib(ans, R_ClassSymbol, Rf_mkString("data.frame"));
d = PROTECT(Rf_allocVector(INTSXP ,n));
for(size_t i=0; i<n; i++){
INTEGER(d)[i] = i+1;
}
Rf_setAttrib(ans, R_RowNamesSymbol, d);
UNPROTECT(3);
JL_GC_POP();
return ans;
}
SEXP string_to_try_error__impl( const std::string& str){
// form simple error condition based on a string
Scoped<SEXP> simpleErrorExpr = ::Rf_lang2(::Rf_install("simpleError"), Rf_mkString(str.c_str()));
Scoped<SEXP> simpleError = Rf_eval(simpleErrorExpr, R_GlobalEnv);
Scoped<SEXP> tryError = Rf_mkString( str.c_str() ) ;
Rf_setAttrib( tryError, R_ClassSymbol, Rf_mkString("try-error") ) ;
Rf_setAttrib( tryError, Rf_install( "condition") , simpleError ) ;
return tryError;
}
static au_instance_t *audiounits_create_recorder(SEXP source, float rate, int chs, int flags) {
UInt32 propsize=0;
OSStatus err;
au_instance_t *ap = (au_instance_t*) calloc(sizeof(au_instance_t), 1);
ap->source = source;
ap->sample_rate = rate;
ap->done = NO;
ap->position = 0;
ap->length = LENGTH(source);
ap->stereo = (chs == 2) ? YES : NO;
propsize = sizeof(ap->inDev);
err = AudioHardwareGetProperty(kAudioHardwarePropertyDefaultInputDevice, &propsize, &ap->inDev);
if (err) {
free(ap);
Rf_error("unable to find default audio input (%08x)", err);
}
propsize = sizeof(ap->fmtIn);
err = AudioDeviceGetProperty(ap->inDev, 0, YES, kAudioDevicePropertyStreamFormat, &propsize, &ap->fmtIn);
if (err) {
free(ap);
Rf_error("unable to retrieve audio input format (%08x)", err);
}
/* Rprintf(" recording format: %f, chs: %d, fpp: %d, bpp: %d, bpf: %d, flags: %x\n", ap->fmtIn.mSampleRate, ap->fmtIn.mChannelsPerFrame, ap->fmtIn.mFramesPerPacket, ap->fmtIn.mBytesPerPacket, ap->fmtIn.mBytesPerFrame, ap->fmtIn.mFormatFlags); */
ap->srFrac = 1.0;
if (ap->fmtIn.mSampleRate != ap->sample_rate) ap->srFrac = ap->sample_rate / ap->fmtIn.mSampleRate;
ap->srRun = 0.0;
#if defined(MAC_OS_X_VERSION_10_5) && (MAC_OS_X_VERSION_MIN_REQUIRED>=MAC_OS_X_VERSION_10_5)
err = AudioDeviceCreateIOProcID(ap->inDev, inputRenderProc, ap, &ap->inIOProcID );
#else
err = AudioDeviceAddIOProc(ap->inDev, inputRenderProc, ap);
#endif
if (err) {
free(ap);
Rf_error("unable to register recording callback (%08x)", err);
}
R_PreserveObject(ap->source);
Rf_setAttrib(ap->source, Rf_install("rate"), Rf_ScalarInteger(rate)); /* we adjust the rate */
Rf_setAttrib(ap->source, Rf_install("bits"), Rf_ScalarInteger(16)); /* we say it's 16 because we don't know - float is always 32-bit */
Rf_setAttrib(ap->source, Rf_install("class"), Rf_mkString("audioSample"));
if (ap->stereo) {
SEXP dim = Rf_allocVector(INTSXP, 2);
INTEGER(dim)[0] = 2;
INTEGER(dim)[1] = LENGTH(ap->source) / 2;
Rf_setAttrib(ap->source, R_DimSymbol, dim);
}
return ap;
}
SEXP ocl_ez_kernel(SEXP device, SEXP k_name, SEXP code, SEXP prec) {
cl_context ctx;
int err;
SEXP sctx;
cl_device_id device_id = getDeviceID(device);
cl_program program;
cl_kernel kernel;
if (TYPEOF(k_name) != STRSXP || LENGTH(k_name) != 1)
Rf_error("invalid kernel name");
if (TYPEOF(code) != STRSXP || LENGTH(code) < 1)
Rf_error("invalid kernel code");
if (TYPEOF(prec) != STRSXP || LENGTH(prec) != 1)
Rf_error("invalid precision specification");
ctx = clCreateContext(0, 1, &device_id, NULL, NULL, &err);
if (!ctx)
ocl_err("clCreateContext");
sctx = PROTECT(mkContext(ctx));
{
int sn = LENGTH(code), i;
const char **cptr;
cptr = (const char **) malloc(sizeof(char*) * sn);
for (i = 0; i < sn; i++)
cptr[i] = CHAR(STRING_ELT(code, i));
program = clCreateProgramWithSource(ctx, sn, cptr, NULL, &err);
free(cptr);
if (!program)
ocl_err("clCreateProgramWithSource");
}
err = clBuildProgram(program, 0, NULL, NULL, NULL, NULL);
if (err != CL_SUCCESS) {
size_t len;
clGetProgramBuildInfo(program, device_id, CL_PROGRAM_BUILD_LOG, sizeof(buffer), buffer, &len);
clReleaseProgram(program);
Rf_error("clGetProgramBuildInfo failed: %s", buffer);
}
kernel = clCreateKernel(program, CHAR(STRING_ELT(k_name, 0)), &err);
clReleaseProgram(program);
if (!kernel)
ocl_err("clCreateKernel");
{
SEXP sk = PROTECT(mkKernel(kernel));
Rf_setAttrib(sk, Rf_install("device"), device);
Rf_setAttrib(sk, Rf_install("precision"), prec);
Rf_setAttrib(sk, Rf_install("context"), sctx);
Rf_setAttrib(sk, Rf_install("name"), k_name);
UNPROTECT(2); /* sk + context */
return sk;
}
}
static SEXP make_condition(const std::string& ex_msg, SEXP call, SEXP cppstack, SEXP classes){
Scoped<SEXP> res = Rf_allocVector( VECSXP, 3 ) ;
Scoped<SEXP> message = Rf_mkString( ex_msg.c_str() ) ;
RCPP_SET_VECTOR_ELT( res, 0, message ) ;
RCPP_SET_VECTOR_ELT( res, 1, call ) ;
RCPP_SET_VECTOR_ELT( res, 2, cppstack ) ;
Scoped<SEXP> names = Rf_allocVector( STRSXP, 3 ) ;
SET_STRING_ELT( names, 0, Rf_mkChar( "message" ) ) ;
SET_STRING_ELT( names, 1, Rf_mkChar( "call" ) ) ;
SET_STRING_ELT( names, 2, Rf_mkChar( "cppstack" ) ) ;
Rf_setAttrib( res, R_NamesSymbol, names ) ;
Rf_setAttrib( res, R_ClassSymbol, classes ) ;
return res ;
}
SEXP R_mpc_mul(SEXP e1, SEXP e2) {
/* N.B. We always use signed integers for e2 given R's type system. */
mpc_t *z = (mpc_t *)malloc(sizeof(mpc_t));
if (Rf_inherits(e1, "mpc")) {
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpc_init2(*z, max(mpc_get_prec(*z1),
mpc_get_prec(*z2)));
mpc_mul(*z, *z1, *z2, Rmpc_get_rounding());
} else if (Rf_isInteger(e2)) {
mpc_init2(*z, mpc_get_prec(*z1));
mpc_mul_si(*z, *z1, INTEGER(e2)[0],
Rmpc_get_rounding());
} else if (Rf_isNumeric(e2)) {
mpc_init2(*z, mpc_get_prec(*z1));
mpfr_t x;
mpfr_init2(x, 53);
mpfr_set_d(x, REAL(e2)[0], GMP_RNDN);
mpc_mul_fr(*z, *z1, x, Rmpc_get_rounding());
} else {
Rf_error("Invalid second operand for mpc multiplication.");
}
} else {
Rf_error("Invalid first operand for MPC multiplication.");
}
SEXP retVal = PROTECT(R_MakeExternalPtr((void *)z,
Rf_install("mpc ptr"), R_NilValue));
Rf_setAttrib(retVal, R_ClassSymbol, Rf_mkString("mpc"));
R_RegisterCFinalizerEx(retVal, mpcFinalizer, TRUE);
UNPROTECT(1);
return retVal;
}
SEXP dbarts_makeModelMatrixFromDataFrame(SEXP x, SEXP dropColumnsExpr)
{
int errorCode = 0;
SEXP result = R_NilValue;
SEXP dropPatternExpr = R_NilValue;
int protectCount = 0;
size_t numInputColumns = (size_t) rc_getLength(x);
size_t numOutputColumns = 0;
column_type columnTypes[numInputColumns];
getColumnTypes(x, columnTypes);
bool createDropPattern = false;
if (Rf_isLogical(dropColumnsExpr)) {
createDropPattern = LOGICAL(dropColumnsExpr)[0] == TRUE;
if (createDropPattern) {
dropPatternExpr = PROTECT(rc_newList(numInputColumns));
++protectCount;
if (rc_getNames(x) != R_NilValue) rc_setNames(dropPatternExpr, rc_getNames(x));
}
} else if (!createDropPattern && Rf_isVector(dropColumnsExpr)) {
dropPatternExpr = dropColumnsExpr;
}
countMatrixColumns(x, columnTypes, dropPatternExpr, createDropPattern, &numOutputColumns);
size_t numRows = getNumRowsForDataFrame(x);
if (numRows == 0) {
errorCode = EINVAL;
goto mkmm_cleanup;
}
result = PROTECT(rc_newReal(numRows * numOutputColumns));
++protectCount;
rc_setDims(result, (int) numRows, (int) numOutputColumns, -1);
SEXP dimNamesExpr = PROTECT(rc_newList(2));
rc_setDimNames(result, dimNamesExpr);
UNPROTECT(1);
SET_VECTOR_ELT(dimNamesExpr, 1, rc_newCharacter(numOutputColumns));
errorCode = createMatrix(x, numRows, result, columnTypes, dropPatternExpr);
mkmm_cleanup:
if (errorCode != 0) {
if (protectCount > 0) UNPROTECT(protectCount);
Rf_warning("error in makeModelMatrix: %s", strerror(errorCode));
return R_NilValue;
}
if (dropPatternExpr != NULL) Rf_setAttrib(result, Rf_install("drop"), dropPatternExpr);
if (protectCount > 0) UNPROTECT(protectCount);
return result;
}
SEXP R_mpc_pow(SEXP e1, SEXP e2) {
mpc_t *z = (mpc_t *)malloc(sizeof(mpc_t));
if (Rf_inherits(e1, "mpc")) {
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpc_init2(*z, max(mpc_get_prec(*z1),
mpc_get_prec(*z2)));
mpc_pow(*z, *z1, *z2, Rmpc_get_rounding());
} else if (Rf_isInteger(e2)) {
mpc_init2(*z, mpc_get_prec(*z1));
mpc_pow_si(*z, *z1, INTEGER(e2)[0],
Rmpc_get_rounding());
} else if (Rf_isNumeric(e2)) {
mpc_init2(*z, mpc_get_prec(*z1));
mpc_pow_d(*z, *z1, REAL(e2)[0], Rmpc_get_rounding());
} else {
Rf_error("Invalid second operand for mpc power.");
}
} else {
Rf_error("Invalid first operand for MPC power.");
}
SEXP retVal = PROTECT(R_MakeExternalPtr((void *)z,
Rf_install("mpc ptr"), R_NilValue));
Rf_setAttrib(retVal, R_ClassSymbol, Rf_mkString("mpc"));
R_RegisterCFinalizerEx(retVal, mpcFinalizer, TRUE);
UNPROTECT(1);
return retVal;
}
SEXP jr_dict(jl_value_t *tt)
{
SEXP ans = R_NilValue;
SEXP rnames;
jl_function_t *str = jl_get_function(jl_base_module, "string");
jl_function_t *getindex = jl_get_function(jl_base_module, "getindex");
jl_array_t *keys = (jl_array_t *) jl_call1(
jl_get_function(jl_base_module, "collect"),
jl_call1(jl_get_function(jl_base_module, "keys"), tt)
);
size_t m = jl_array_len(keys);
PROTECT(rnames = Rf_allocVector(STRSXP, m));
PROTECT(ans = Rf_allocVector(VECSXP, m));
jl_value_t *key, *value;
for(size_t i=0; i<m; i++)
{
key = jl_arrayref(keys, i);
value = jl_call2(getindex, tt, key);
SET_VECTOR_ELT(ans, i, jr_cast(value));
key = jl_call1(str, key);
SET_STRING_ELT(rnames, i, Rf_mkChar(jl_string_data(key)));
}
Rf_setAttrib(ans, R_NamesSymbol, rnames);
UNPROTECT(2);
return ans;
}
/**
* Sets the dim attribute vector for a SEXP.
*/
void setRDims(SEXP s, std::vector<int>& dims) {
if(dims.size() <= 0)
throw std::range_error("Invalid dims in setRDims");
Rcpp::IntegerVector iv(dims.size());
for(int i=0; i < (int)dims.size(); ++i)
iv[i] = dims[i];
Rf_setAttrib(s, R_DimSymbol, iv);
}
SEXP audio_drivers_list() {
int n = 0;
SEXP res = Rf_allocVector(VECSXP, 3), sName, sDesc, /* sCopy, */ sCurr, sLN, sRN;
audio_driver_list_t *l = &audio_drivers;
if (!current_driver)
load_default_audio_driver(1);
Rf_protect(res);
if (l->driver) {
while (l) {
n++;
l = l->next;
}
}
sName = Rf_allocVector(STRSXP, n); SET_VECTOR_ELT(res, 0, sName);
sDesc = Rf_allocVector(STRSXP, n); SET_VECTOR_ELT(res, 1, sDesc);
sCurr = Rf_allocVector(LGLSXP, n); SET_VECTOR_ELT(res, 2, sCurr);
/* sCopy = Rf_allocVector(STRSXP, n); SET_VECTOR_ELT(res, 3, sCopy); */
if (n) {
n = 0;
l = &audio_drivers;
while (l) {
const char *s = l->driver->name;
SET_STRING_ELT(sName, n, Rf_mkChar(s ? s : ""));
s = l->driver->descr;
SET_STRING_ELT(sDesc, n, Rf_mkChar(s ? s : ""));
s = l->driver->copyright;
/* SET_STRING_ELT(sCopy, n, Rf_mkChar(s ? s : "")); */
LOGICAL(sCurr)[n] = (l->driver == current_driver) ? 1 : 0;
l = l->next;
n++;
}
}
sLN = Rf_allocVector(STRSXP, 3);
Rf_setAttrib(res, R_NamesSymbol, sLN);
SET_STRING_ELT(sLN, 0, Rf_mkChar("name"));
SET_STRING_ELT(sLN, 1, Rf_mkChar("description"));
SET_STRING_ELT(sLN, 2, Rf_mkChar("current"));
/* SET_STRING_ELT(sLN, 3, Rf_mkChar("author")); */
sRN = Rf_allocVector(INTSXP, 2);
Rf_setAttrib(res, R_RowNamesSymbol, sRN);
INTEGER(sRN)[0] = R_NaInt;
INTEGER(sRN)[1] = -n;
Rf_setAttrib(res, R_ClassSymbol, Rf_mkString("data.frame"));
Rf_unprotect(1);
return res;
}
/* MakeMPC - Create an MPC ExternalPtr object for R based on a C mpc_t.
*
* Args:
* z - An mpc_t pointer.
* Returns:
* An S3 object of type "mpc" containing the external pointer to z.
*/
SEXP MakeMPC(mpc_t *z) {
SEXP retVal = PROTECT(R_MakeExternalPtr((void *)z,
Rf_install("mpc ptr"), R_NilValue));
Rf_setAttrib(retVal, R_ClassSymbol, Rf_mkString("mpc"));
R_RegisterCFinalizerEx(retVal, mpcFinalizer, TRUE);
UNPROTECT(1);
return retVal;
}
static SEXP mkKernel(cl_kernel k) {
SEXP ptr;
ptr = PROTECT(R_MakeExternalPtr(k, R_NilValue, R_NilValue));
R_RegisterCFinalizerEx(ptr, clFreeKernel, TRUE);
Rf_setAttrib(ptr, R_ClassSymbol, mkString("clKernel"));
UNPROTECT(1);
return ptr;
}
static SEXP mkContext(cl_context ctx) {
SEXP ptr;
ptr = PROTECT(R_MakeExternalPtr(ctx, R_NilValue, R_NilValue));
R_RegisterCFinalizerEx(ptr, clFreeContext, TRUE);
Rf_setAttrib(ptr, R_ClassSymbol, mkString("clContext"));
UNPROTECT(1);
return ptr;
}
/** Set POSIXct class on a given object
*
* @param x R object
*
* @version 0.5-1 (Marek Gagolewski, 2014-12-29)
*/
void stri__set_class_POSIXct(SEXP x) {
SEXP cl;
PROTECT(cl = Rf_allocVector(STRSXP, 2));
// SET_STRING_ELT(cl, 0, Rf_mkChar("POSIXst"));
SET_STRING_ELT(cl, 0, Rf_mkChar("POSIXct"));
SET_STRING_ELT(cl, 1, Rf_mkChar("POSIXt"));
Rf_setAttrib(x, R_ClassSymbol, cl);
UNPROTECT(1);
}
void
Sexp_setAttribute(SEXP sexp,
char *name,
const SEXP sexp_attr) {
if (! RINTERF_ISREADY()) {
return;
}
Rf_setAttrib(sexp, Rf_install(name), sexp_attr);
}
template <> SEXP wrap(const RcppDateVector& datevec) {
SEXP value = PROTECT(Rf_allocVector(REALSXP, datevec.size()));
double* p = REAL(value) ;
for (int i = 0; i < datevec.size(); i++,p++) {
*p = datevec(i).getJDN() - RcppDate::Jan1970Offset;
}
Rf_setAttrib(value, R_ClassSymbol, Rf_mkString("Date"));
UNPROTECT(1);
return value;
}
static SEXP mkDeviceID(cl_device_id id) {
SEXP ptr;
cl_device_id *pp = (cl_device_id*) malloc(sizeof(cl_device_id));
pp[0] = id;
ptr = PROTECT(R_MakeExternalPtr(pp, R_NilValue, R_NilValue));
R_RegisterCFinalizerEx(ptr, clFreeFin, TRUE);
Rf_setAttrib(ptr, R_ClassSymbol, mkString("clDeviceID"));
UNPROTECT(1);
return ptr;
}
template <> SEXP wrap(const RcppDatetimeVector &dtvec) {
SEXP value = PROTECT(Rf_allocVector(REALSXP, dtvec.size()));
double* p = REAL(value) ;
for (int i = 0; i < dtvec.size(); i++,p++) {
*p = dtvec(i).getFractionalTimestamp();
}
Rf_setAttrib(value, R_ClassSymbol, internal::getPosixClasses() );
UNPROTECT(1);
return value;
}
void rlang_register_pointer(const char* ns, const char* ptr_name, DL_FUNC fn) {
SEXP ptr = PROTECT(R_MakeExternalPtrFn(fn, R_NilValue, R_NilValue));
SEXP ptr_obj = PROTECT(Rf_allocVector(VECSXP, 1));
SET_VECTOR_ELT(ptr_obj, 0, ptr);
Rf_setAttrib(ptr_obj, R_ClassSymbol, Rf_mkString("fn_pointer"));
Rf_defineVar(Rf_install(ptr_name), ptr_obj, rlang_namespace(ns));
UNPROTECT(2);
}
void omxLISRELExpectation::populateAttr(SEXP algebra)
{
auto oo = this;
ProtectedSEXP RnumStat(Rf_ScalarReal(omxDataDF(oo->data)));
Rf_setAttrib(algebra, Rf_install("numStats"), RnumStat);
/*
omxLISRELExpectation* oro = (omxLISRELExpectation*) (oo->argStruct);
omxMatrix* LX = oro->LX;
omxMatrix* LY = oro->LY;
omxMatrix* BE = oro->BE;
omxMatrix* GA = oro->GA;
omxMatrix* PH = oro->PH;
omxMatrix* PS = oro->PS;
omxMatrix* TD = oro->TD;
omxMatrix* TE = oro->TE;
omxMatrix* TH = oro->TH;
omxMatrix* LXPH = oro->LXPH;
omxMatrix* GAPH = oro->GAPH;
omxMatrix* W = oro->W;
omxMatrix* U = oro->U;
omxMatrix* I = oro->I;
int numIters = oro->numIters;
double oned = 1.0, zerod = 0.0;
omxRecompute(LX);
omxRecompute(LY);
*/ //This block of code works fine but because I do not use any of it later, it throws a huge block of Rf_warnings about unused variables.
// In general, I do not yet understand what this function needs to do.
/*
omxShallowInverse(numIters, BE, Z, Ax, I ); // Z = (I-A)^-1
if(OMX_DEBUG_ALGEBRA) { mxLog("....DGEMM: %c %c \n %d %d %d \n %f \n %x %d %x %d \n %f %x %d.", *(Z->majority), *(S->majority), (Z->rows), (S->cols), (S->rows), oned, Z->data, (Z->leading), S->data, (S->leading), zerod, Ax->data, (Ax->leading));}
// F77_CALL(omxunsafedgemm)(Z->majority, S->majority, &(Z->rows), &(S->cols), &(S->rows), &oned, Z->data, &(Z->leading), S->data, &(S->leading), &zerod, Ax->data, &(Ax->leading)); // X = ZS
omxDGEMM(FALSE, FALSE, oned, Z, S, zerod, Ax);
if(OMX_DEBUG_ALGEBRA) { mxLog("....DGEMM: %c %c %d %d %d %f %x %d %x %d %f %x %d.", *(Ax->majority), *(Z->minority), (Ax->rows), (Z->rows), (Z->cols), oned, X->data, (X->leading), Z->data, (Z->lagging), zerod, Ax->data, (Ax->leading));}
// F77_CALL(omxunsafedgemm)(Ax->majority, Z->minority, &(Ax->rows), &(Z->rows), &(Z->cols), &oned, Ax->data, &(Ax->leading), Z->data, &(Z->leading), &zerod, Ax->data, &(Ax->leading));
omxDGEMM(FALSE, TRUE, oned, Ax, Z, zerod, Ax);
// Ax = ZSZ' = Covariance matrix including latent variables
SEXP expCovExt;
Rf_protect(expCovExt = Rf_allocMatrix(REALSXP, Ax->rows, Ax->cols));
for(int row = 0; row < Ax->rows; row++)
for(int col = 0; col < Ax->cols; col++)
REAL(expCovExt)[col * Ax->rows + row] =
omxMatrixElement(Ax, row, col);
setAttrib(algebra, Rf_install("UnfilteredExpCov"), expCovExt);
*/
}
JulianBackend(const TSDIM rows, const TSDIM cols) : BackendBase(Rallocator<TDATA>::getType(), rows, cols) {
// create dates
SEXP R_dates = PROTECT(Rallocator<TDATE>::Vector(rows));
// create and add dates class to dates object
SEXP r_dates_class = PROTECT(Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(r_dates_class, 0, Rf_mkChar("Date"));
Rf_classgets(R_dates, r_dates_class);
// attach dates to Robject
Rf_setAttrib(Robject, Rf_install("index"), R_dates);
UNPROTECT(2); // R_dates, r_dates_class
}
void omxPopulateNormalAttributes(omxExpectation *ox, SEXP algebra) {
if(OMX_DEBUG) { mxLog("Populating Normal Attributes."); }
omxNormalExpectation* one = (omxNormalExpectation*) (ox->argStruct);
omxMatrix *cov = one->cov;
omxMatrix *means = one->means;
omxRecompute(cov, NULL);
if(means != NULL) omxRecompute(means, NULL);
{
SEXP expCovExt;
ScopedProtect p1(expCovExt, Rf_allocMatrix(REALSXP, cov->rows, cov->cols));
for(int row = 0; row < cov->rows; row++)
for(int col = 0; col < cov->cols; col++)
REAL(expCovExt)[col * cov->rows + row] =
omxMatrixElement(cov, row, col);
Rf_setAttrib(algebra, Rf_install("ExpCov"), expCovExt);
}
if (means != NULL) {
SEXP expMeanExt;
ScopedProtect p1(expMeanExt, Rf_allocMatrix(REALSXP, means->rows, means->cols));
for(int row = 0; row < means->rows; row++)
for(int col = 0; col < means->cols; col++)
REAL(expMeanExt)[col * means->rows + row] =
omxMatrixElement(means, row, col);
Rf_setAttrib(algebra, Rf_install("ExpMean"), expMeanExt);
} else {
SEXP expMeanExt;
ScopedProtect p1(expMeanExt, Rf_allocMatrix(REALSXP, 0, 0));
Rf_setAttrib(algebra, Rf_install("ExpMean"), expMeanExt);
}
Rf_setAttrib(algebra, Rf_install("numStats"), Rf_ScalarReal(omxDataDF(ox->data)));
}
/**
* MAP is not affected by the number of items. EAP is. Likelihood can
* get concentrated in a single quadrature ordinate. For 3PL, response
* patterns can have a bimodal likelihood. This will confuse MAP and
* is a key advantage of EAP (Thissen & Orlando, 2001, p. 136).
*
* Thissen, D. & Orlando, M. (2001). IRT for items scored in two
* categories. In D. Thissen & H. Wainer (Eds.), \emph{Test scoring}
* (pp 73-140). Lawrence Erlbaum Associates, Inc.
*/
static void
ba81PopulateAttributes(omxExpectation *oo, SEXP robj)
{
BA81Expect *state = (BA81Expect *) oo->argStruct;
if (!state->debugInternal) return;
ba81NormalQuad &quad = state->getQuad();
int maxAbilities = quad.abilities();
const int numUnique = state->getNumUnique();
const double LogLargest = state->LogLargestDouble;
SEXP Rlik;
if (state->grp.patternLik.size() != numUnique) {
refreshPatternLikelihood(state, oo->dynamicDataSource);
}
Rf_protect(Rlik = Rf_allocVector(REALSXP, numUnique));
memcpy(REAL(Rlik), state->grp.patternLik.data(), sizeof(double) * numUnique);
double *lik_out = REAL(Rlik);
for (int px=0; px < numUnique; ++px) {
// Must return value in log units because it may not be representable otherwise
lik_out[px] = log(lik_out[px]) - LogLargest;
}
MxRList dbg;
dbg.add("patternLikelihood", Rlik);
if (quad.getEstepTableSize(0)) {
SEXP Rexpected;
Rf_protect(Rexpected = Rf_allocVector(REALSXP, quad.getEstepTableSize(0)));
Eigen::Map< Eigen::ArrayXd > box(REAL(Rexpected), quad.getEstepTableSize(0));
quad.exportEstepTable(0, box);
dbg.add("em.expected", Rexpected);
}
SEXP Rmean, Rcov;
if (state->estLatentMean) {
Rf_protect(Rmean = Rf_allocVector(REALSXP, maxAbilities));
memcpy(REAL(Rmean), state->estLatentMean->data, maxAbilities * sizeof(double));
dbg.add("mean", Rmean);
}
if (state->estLatentCov) {
Rf_protect(Rcov = Rf_allocMatrix(REALSXP, maxAbilities, maxAbilities));
memcpy(REAL(Rcov), state->estLatentCov->data, maxAbilities * maxAbilities * sizeof(double));
dbg.add("cov", Rcov);
}
Rf_setAttrib(robj, Rf_install("debug"), dbg.asR());
}
USER_OBJECT_
createSAX2AttributesList(const xmlChar **attributes, int nb_attributes, int nb_defaulted, const xmlChar *encoding)
{
int i;
const char **ptr;
USER_OBJECT_ attr_names;
USER_OBJECT_ attr_values;
USER_OBJECT_ nsURI, nsNames;
if(nb_attributes < 1)
return(NULL_USER_OBJECT);
PROTECT(attr_values = NEW_CHARACTER(nb_attributes));
PROTECT(attr_names = NEW_CHARACTER(nb_attributes));
PROTECT(nsURI = NEW_CHARACTER(nb_attributes));
PROTECT(nsNames = NEW_CHARACTER(nb_attributes));
ptr = (const char **) attributes; /*XXX */
for(i=0; i < nb_attributes; i++, ptr+=5) {
char *tmp;
int len;
len = (ptr[4] - ptr[3] + 1);
tmp = malloc(sizeof(char) * len);
if(!tmp) {
PROBLEM "Cannot allocate space for attribute of length %d", (int) (ptr[4] - ptr[3] + 2)
ERROR;
}
memcpy(tmp, ptr[3], ptr[4] - ptr[3]);
tmp[len-1] = '\0'; /*XXX*/
SET_STRING_ELT(attr_values, i, ENC_COPY_TO_USER_STRING(tmp));
free(tmp);
SET_STRING_ELT(attr_names, i, ENC_COPY_TO_USER_STRING(ptr[0]));
if(ptr[2]) {
SET_STRING_ELT(nsURI, i, ENC_COPY_TO_USER_STRING(ptr[2]));
if(ptr[1])
SET_STRING_ELT(nsNames, i, ENC_COPY_TO_USER_STRING(ptr[1]));
}
}
SET_NAMES(nsURI, nsNames);
SET_NAMES(attr_values, attr_names);
Rf_setAttrib(attr_values, Rf_install("namespaces"), nsURI);
UNPROTECT(4);
return(attr_values);
}
/** Get the transitive reduction of a binary relation
*
* @param x square logical matrix
* @return square logical matrix
*
* @version 0.2 (Marek Gagolewski)
*/
SEXP rel_reduction_transitive(SEXP x)
{
SEXP cyc = rel_is_cyclic(x);
if (LOGICAL(cyc)[0] != false)
Rf_error(MSG__EXPECTED_ACYCLIC, "R");
x = rel_closure_transitive(x);
// is logical matrix, dimnames are preserved, no NAs, we may overwrite its elements
SEXP dim = Rf_getAttrib(x, R_DimSymbol);
R_len_t n = INTEGER(dim)[0];
int* xp = INTEGER(x);
SEXP y = Rf_allocVector(LGLSXP, n*n);
int* yp = INTEGER(y);
Rf_setAttrib(y, R_DimSymbol, dim);
Rf_setAttrib(y, R_DimNamesSymbol, Rf_getAttrib(x, R_DimNamesSymbol)); // preserve dimnames
// (Aho et al. 1972)
for (R_len_t i=0; i<n; ++i) {
for (R_len_t j=0; j<n; ++j) {
yp[i+n*j] = xp[i+n*j];
if (xp[i+n*j] && i != j) {
// determine whether i -> j may be removed
for (R_len_t k=0; k<n; ++k) {
if (i != k && k != j && xp[i+n*k] && xp[k+n*j]) {
yp[i+n*j] = 0;
break;
}
}
}
}
}
return y;
}
SEXP vflatten_impl(SEXP x, SEXP type_) {
if (TYPEOF(x) != VECSXP) {
stop_bad_type(x, "a list", NULL, ".x");
}
int m = Rf_length(x);
SEXPTYPE type = Rf_str2type(CHAR(Rf_asChar(type_)));
// Determine output size and type
int n = 0;
int has_names = 0;
for (int j = 0; j < m; ++j) {
SEXP x_j = VECTOR_ELT(x, j);
n += Rf_length(x_j);
if (!has_names && !Rf_isNull(Rf_getAttrib(x_j, R_NamesSymbol))) {
has_names = 1;
}
}
SEXP out = PROTECT(Rf_allocVector(type, n));
SEXP names = PROTECT(Rf_allocVector(STRSXP, n));
if (has_names)
Rf_setAttrib(out, R_NamesSymbol, names);
UNPROTECT(1);
int i = 0;
for (int j = 0; j < m; ++j) {
SEXP x_j = VECTOR_ELT(x, j);
int n_j = Rf_length(x_j);
SEXP names_j = PROTECT(Rf_getAttrib(x_j, R_NamesSymbol));
int has_names_j = !Rf_isNull(names_j);
for (int k = 0; k < n_j; ++k, ++i) {
set_vector_value(out, i, x_j, k);
if (has_names)
SET_STRING_ELT(names, i, has_names_j ? STRING_ELT(names_j, k) : Rf_mkChar(""));
if (i % 1024 == 0)
R_CheckUserInterrupt();
}
UNPROTECT(1);
}
UNPROTECT(1);
return out;
}
