Ejemplo n.º 1
0
/** 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;
}
Ejemplo n.º 2
0
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);
	}
}
Ejemplo n.º 3
0
/** 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;
}
Ejemplo n.º 4
0
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;
}
Ejemplo n.º 5
0
 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;
 }
Ejemplo n.º 6
0
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;
}
Ejemplo n.º 7
0
Archivo: ocl.c Proyecto: cran/OpenCL
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;
    }
}
Ejemplo n.º 8
0
 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 ;
 }
Ejemplo n.º 9
0
Archivo: mpc.c Proyecto: rforge/mpc
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;
}
Ejemplo n.º 10
0
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;
}
Ejemplo n.º 11
0
Archivo: mpc.c Proyecto: rforge/mpc
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;
}
Ejemplo n.º 12
0
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;
}
Ejemplo n.º 13
0
/**
 * 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);
}
Ejemplo n.º 14
0
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;	
}
Ejemplo n.º 15
0
Archivo: mpc.c Proyecto: rforge/mpc
/* 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;
}
Ejemplo n.º 16
0
Archivo: ocl.c Proyecto: cran/OpenCL
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;
}
Ejemplo n.º 17
0
Archivo: ocl.c Proyecto: cran/OpenCL
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;
}
Ejemplo n.º 18
0
/** 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);
}
Ejemplo n.º 19
0
void
Sexp_setAttribute(SEXP sexp,
		  char *name,
		  const SEXP sexp_attr) {
  if (! RINTERF_ISREADY()) {
    return;
  }
  Rf_setAttrib(sexp, Rf_install(name), sexp_attr);
}
Ejemplo n.º 20
0
    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;
    }
Ejemplo n.º 21
0
Archivo: ocl.c Proyecto: cran/OpenCL
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;
}
Ejemplo n.º 22
0
    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;
    }
Ejemplo n.º 23
0
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);
}
Ejemplo n.º 24
0
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);
	*/
}
Ejemplo n.º 25
0
  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
  }
Ejemplo n.º 26
0
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)));
}
Ejemplo n.º 27
0
/**
 * 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());
}
Ejemplo n.º 28
0
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);
}
Ejemplo n.º 29
0
/** 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;
}
Ejemplo n.º 30
0
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;
}