SEXP d_nrm2(SEXP rx, SEXP rincx)
{
int
n,
incx = asInteger(rincx);
double * x;
unpackVector(rx, &n, &x);
SEXP out;
PROTECT(out = allocVector(REALSXP, 1));
REAL(out)[0] = cublasDnrm2(n, x, incx);
checkCublasError("d_nrm2");
UNPROTECT(1);
return out;
}
SEXP Fisher_sim(SEXP sr, SEXP sc, SEXP sB)
{
sr = PROTECT(coerceVector(sr, INTSXP));
sc = PROTECT(coerceVector(sc, INTSXP));
int nr = LENGTH(sr), nc = LENGTH(sc), B = asInteger(sB);
int n = 0, *isr = INTEGER(sr);
for (int i = 0; i < nr; i++) n += isr[i];
int *observed = (int *) R_alloc(nr * nc, sizeof(int));
double *fact = (double *) R_alloc(n+1, sizeof(double));
int *jwork = (int *) R_alloc(nc, sizeof(int));
SEXP ans = PROTECT(allocVector(REALSXP, B));
fisher_sim(&nr, &nc, isr, INTEGER(sc), &n, B, observed, fact,
jwork, REAL(ans));
UNPROTECT(3);
return ans;
}
SEXP bw_phi6(SEXP sn, SEXP sd, SEXP cnt, SEXP sh)
{
double h = asReal(sh), d = asReal(sd), sum = 0.0, term, u;
int n = asInteger(sn), nbin = LENGTH(cnt), *x = INTEGER(cnt);
for (int i = 0; i < nbin; i++) {
double delta = i * d / h; delta *= delta;
if (delta >= DELMAX) break;
term = exp(-delta / 2) *
(delta * delta * delta - 15 * delta * delta + 45 * delta - 15);
sum += term * x[i];
}
sum = 2 * sum - 15 * n; /* add in diagonal */
u = sum / (n * (n - 1) * pow(h, 7.0) * sqrt(2 * PI));
return ScalarReal(u);
}
/*
external interface for compare attributes
*/
SEXP ALIKEC_compare_attributes(SEXP target, SEXP current, SEXP attr_mode) {
SEXPTYPE attr_mode_type = TYPEOF(attr_mode);
if(
(attr_mode_type != INTSXP && attr_mode_type != REALSXP) ||
XLENGTH(attr_mode) != 1
)
error("Argument `mode` must be a one length integer like vector");
struct ALIKEC_settings set = ALIKEC_set_def("");
set.attr_mode = asInteger(attr_mode);
struct ALIKEC_res_sub comp_res =
ALIKEC_compare_attributes_internal(target, current, set);
return ALIKEC_res_sub_as_sxp(comp_res);
}
SEXP dgCMatrix_LU(SEXP Ap, SEXP orderp, SEXP tolp, SEXP error_on_sing)
{
SEXP ans;
Rboolean err_sing = asLogical(error_on_sing);
/* FIXME: dgCMatrix_LU should check ans for consistency in
* permutation type with the requested value - Should have two
* classes or two different names in the factors list for LU with
* permuted columns or not.
* OTOH, currently (order, tol) === (1, 1) always.
* It is true that length(LU@q) does flag the order argument.
*/
if (!isNull(ans = get_factors(Ap, "LU")))
return ans;
install_lu(Ap, asInteger(orderp), asReal(tolp), err_sing);
return get_factors(Ap, "LU");
}
SEXP PKI_extract_key(SEXP sKey, SEXP sPriv) {
SEXP res;
EVP_PKEY *key;
RSA *rsa;
int get_priv = asInteger(sPriv), len;
if (!inherits(sKey, "public.key") && !inherits(sKey, "private.key"))
Rf_error("invalid key object");
if (get_priv == NA_INTEGER)
get_priv = inherits(sKey, "private.key");
if (get_priv && !inherits(sKey, "private.key"))
return R_NilValue;
key = (EVP_PKEY*) R_ExternalPtrAddr(sKey);
if (!key)
Rf_error("NULL key");
PKI_init();
if (EVP_PKEY_type(key->type) != EVP_PKEY_RSA)
Rf_error("Sorry only RSA keys are supported at this point");
rsa = EVP_PKEY_get1_RSA(key);
if (get_priv) {
unsigned char *ptr;
len = i2d_RSAPrivateKey(rsa, 0);
if (len < 1)
Rf_error("%s", ERR_error_string(ERR_get_error(), NULL));
res = allocVector(RAWSXP, len);
ptr = (unsigned char*) RAW(res);
len = i2d_RSAPrivateKey(rsa, &ptr);
if (len < 1)
Rf_error("%s", ERR_error_string(ERR_get_error(), NULL));
PROTECT(res);
setAttrib(res, R_ClassSymbol, mkString("private.key.DER"));
UNPROTECT(1);
} else {
unsigned char *ptr;
len = i2d_RSA_PUBKEY(rsa, 0);
if (len < 1)
Rf_error("%s", ERR_error_string(ERR_get_error(), NULL));
res = allocVector(RAWSXP, len);
ptr = (unsigned char*) RAW(res);
len = i2d_RSA_PUBKEY(rsa, &ptr);
if (len < 1)
Rf_error("%s", ERR_error_string(ERR_get_error(), NULL));
PROTECT(res);
setAttrib(res, R_ClassSymbol, mkString("public.key.DER"));
UNPROTECT(1);
}
return res;
}
void d_spr(SEXP ruplo, SEXP ralpha, SEXP rx, SEXP rincx, SEXP ra)
{
char
uplo = getSymLoc(ruplo);
double
alpha = asReal(ralpha),
* a, * x;
int
rowsa, colsa,
nx, incx = asInteger(rincx);
unpackVector(rx, &nx, &x);
unpackMatrix(ra, &rowsa, &colsa, &a);
cublasDspr(uplo, rowsa, alpha, x, incx, a);
checkCublasError("d_spr");
}
SEXP advancePointer(SEXP ptr, SEXP inc)
{
if(isNull(ptr) || !R_ExternalPtrAddr(ptr))
error("ardblas: unpackVector: improperly formatted pointer");
if(inc <= 0)
error("ardblas: unpackVector: amount to advance pointer not positive");
double * newPtr = R_ExternalPtrAddr(ptr);
int increment = asInteger(inc);
newPtr += increment;
SEXP new_ptr;
PROTECT(new_ptr = R_MakeExternalPtr(newPtr, R_NilValue, R_NilValue));
R_RegisterCFinalizerEx(new_ptr, d_finalizer, TRUE);
UNPROTECT(1);
return new_ptr;
}
SEXP CHMfactor_solve(SEXP a, SEXP b, SEXP system)
{
CHM_FR L = AS_CHM_FR(a);
SEXP bb = PROTECT(dup_mMatrix_as_dgeMatrix(b));
CHM_DN B = AS_CHM_DN(bb), X;
int sys = asInteger(system);
R_CheckStack();
if (!(sys--)) /* align with CHOLMOD defs: R's {1:9} --> {0:8},
see ./CHOLMOD/Cholesky/cholmod_solve.c */
error(_("system argument is not valid"));
X = cholmod_solve(sys, L, B, &c);
UNPROTECT(1);
return chm_dense_to_SEXP(X, 1/*do_free*/, 0/*Rkind*/,
GET_SLOT(bb, Matrix_DimNamesSym), FALSE);
}
SEXP
RGDAL_GetRasterBand(SEXP sDataset, SEXP sBand) {
GDALDataset *pDataset = getGDALDatasetPtr(sDataset);
int band = asInteger(sBand);
installErrorHandler();
GDALRasterBand *pRasterBand = pDataset->GetRasterBand(band);
uninstallErrorHandlerAndTriggerError();
SEXP rpRasterBand = R_MakeExternalPtr((void *) pRasterBand,
mkChar("GDAL Raster Band"),
R_NilValue);
return(rpRasterBand);
}
SEXP
R_double_avoidCast(SEXP els, SEXP repeats)
{
int i, val, n, j;
int numRepeats = asInteger(repeats);
if(TYPEOF(els) == INTSXP)
els = coerceVector(els, REALSXP);
n = LENGTH(els);
for(j = 0; j < numRepeats ; j++) {
for(i = 0; i < n ; i++)
val += REAL(els)[i];
}
return(ScalarReal(val));
}
SEXP Rsocklisten(SEXP ssock)
{
if (length(ssock) != 1) error("invalid 'socket' argument");
int sock = asInteger(ssock), len = 256;
char buf[257], *abuf[1];
abuf[0] = buf;
if(!initialized) internet_Init();
if(initialized > 0)
(*ptr->socklisten)(&sock, abuf, &len);
else
error(_("socket routines cannot be loaded"));
SEXP ans = PROTECT(ScalarInteger(sock)); // The socket being listened on
SEXP host = PROTECT(Rf_ScalarString(mkChar(buf)));
setAttrib(ans, install("host"), host);
UNPROTECT(2);
return ans;
}
/* Wrapper to fits_movabs_hdu */
SEXP
cfitsio_movrel_hdu (SEXP fits_object,
SEXP hdu_num)
{
fits_file_t * fits = R_ExternalPtrAddr (fits_object);
if (NULL != fits && NULL != fits->cfitsio_ptr)
{
int hdu_type;
fits_movrel_hdu (fits->cfitsio_ptr, asInteger (hdu_num),
&hdu_type, &(fits->status));
return mkString (hdu_type_name (hdu_type));
}
else
return mkString (ERROR_STR);
}
SEXP count(SEXP x, SEXP idxs, SEXP value, SEXP what, SEXP naRm, SEXP hasNA) {
SEXP ans;
int narm, hasna, what2;
R_xlen_t nx;
/* Argument 'x' and 'dim': */
assertArgVector(x, (R_TYPE_LGL | R_TYPE_INT | R_TYPE_REAL), "x");
nx = xlength(x);
/* Argument 'value': */
if (length(value) != 1)
error("Argument 'value' must be a single value.");
if (!isNumeric(value))
error("Argument 'value' must be a numeric value.");
/* Argument 'what': */
what2 = asInteger(what);
/* Argument 'naRm': */
narm = asLogicalNoNA(naRm, "na.rm");
/* Argument 'hasNA': */
hasna = asLogicalNoNA(hasNA, "hasNA");
/* Argument 'idxs': */
R_xlen_t nrows, ncols = 1;
int rowsType, colsType = SUBSETTED_ALL;
void *crows = validateIndices(idxs, nx, 1, &nrows, &rowsType);
void *ccols = NULL;
/* R allocate a integer scalar */
PROTECT(ans = allocVector(INTSXP, 1));
if (isReal(x)) {
colCounts_Real[rowsType][colsType](REAL(x), nx, 1, crows, nrows, ccols, ncols, asReal(value), what2, narm, hasna, INTEGER(ans));
} else if (isInteger(x)) {
colCounts_Integer[rowsType][colsType](INTEGER(x), nx, 1, crows, nrows, ccols, ncols, asInteger(value), what2, narm, hasna, INTEGER(ans));
} else if (isLogical(x)) {
colCounts_Logical[rowsType][colsType](LOGICAL(x), nx, 1, crows, nrows, ccols, ncols, asLogical(value), what2, narm, hasna, INTEGER(ans));
}
UNPROTECT(1);
return(ans);
} // count()
/* Also does all.vars with functions=FALSE
.Internal(all.names(expr, functions, max.names, unique)) */
SEXP attribute_hidden do_allnames(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP expr;
int i, savecount;
NameWalkData data = {NULL, 0, 0, 0, 0, 0};
checkArity(op, args);
expr = CAR(args);
args = CDR(args);
data.IncludeFunctions = asLogical(CAR(args));
if(data.IncludeFunctions == NA_LOGICAL)
data.IncludeFunctions = 0;
args = CDR(args);
data.MaxCount = asInteger(CAR(args));
if(data.MaxCount == -1) data.MaxCount = INT_MAX;
if(data.MaxCount < 0 || data.MaxCount == NA_INTEGER)
data.MaxCount = 0;
args = CDR(args);
data.UniqueNames = asLogical(CAR(args));
if(data.UniqueNames == NA_LOGICAL)
data.UniqueNames = 1;
namewalk(expr, &data);
savecount = data.ItemCounts;
data.ans = allocVector(STRSXP, data.ItemCounts);
data.StoreValues = 1;
data.ItemCounts = 0;
namewalk(expr, &data);
if(data.ItemCounts != savecount) {
PROTECT(expr = data.ans);
data.ans = allocVector(STRSXP, data.ItemCounts);
for(i = 0 ; i < data.ItemCounts ; i++)
SET_STRING_ELT(data.ans, i, STRING_ELT(expr, i));
UNPROTECT(1);
}
return data.ans;
}
SEXP
RGDAL_CopyDataset(SEXP sxpDataset, SEXP sxpDriver,
SEXP sxpStrict, SEXP sxpOpts,
SEXP sxpFile) {
GDALDataset *pDataset = getGDALDatasetPtr(sxpDataset);
char **papszCreateOptions = NULL;
int i;
const char *filename = asString(sxpFile);
if (filename == NULL) error("Invalid filename\n");
GDALDriver *pDriver = getGDALDriverPtr(sxpDriver);
installErrorHandler();
for (i=0; i < length(sxpOpts); i++) papszCreateOptions = CSLAddString(
papszCreateOptions, CHAR(STRING_ELT(sxpOpts, i)) );
uninstallErrorHandlerAndTriggerError();
#ifdef RGDALDEBUG
installErrorHandler();
for (i=0; i < CSLCount(papszCreateOptions); i++)
Rprintf("option %d: %s\n", i, CSLGetField(papszCreateOptions, i));
uninstallErrorHandlerAndTriggerError();
#endif
installErrorHandler();
GDALDataset *pDatasetCopy = pDriver->CreateCopy(filename,
pDataset, asInteger(sxpStrict),
papszCreateOptions, NULL, NULL);
uninstallErrorHandlerAndTriggerError();
if (pDatasetCopy == NULL) error("Dataset copy failed\n");
installErrorHandler();
CSLDestroy(papszCreateOptions);
uninstallErrorHandlerAndTriggerError();
SEXP sxpHandle = R_MakeExternalPtr((void *) pDatasetCopy,
mkChar("GDAL Dataset"),
R_NilValue);
return(sxpHandle);
}
SEXP weightedMedian(SEXP x, SEXP w, SEXP idxs, SEXP naRm, SEXP interpolate, SEXP ties) {
SEXP ans;
int narm, interpolate2, ties2;
double mu = NA_REAL;
R_xlen_t nx, nw;
/* Argument 'x': */
assertArgVector(x, (R_TYPE_INT | R_TYPE_REAL), "x");
nx = xlength(x);
/* Argument 'x': */
assertArgVector(w, (R_TYPE_REAL), "w");
nw = xlength(w);
if (nx != nw) {
error("Argument 'x' and 'w' are of different lengths: %d != %d", nx, nw);
}
/* Argument 'naRm': */
narm = asLogicalNoNA(naRm, "na.rm");
/* Argument 'interpolate': */
interpolate2 = asLogicalNoNA(interpolate, "interpolate");
/* Argument 'idxs': */
R_xlen_t nidxs;
int idxsType;
void *cidxs = validateIndices(idxs, nx, 1, &nidxs, &idxsType);
/* Argument 'ties': */
ties2 = asInteger(ties);
/* Double matrices are more common to use. */
if (isReal(x)) {
mu = weightedMedian_Real[idxsType](REAL(x), nx, REAL(w), cidxs, nidxs, narm, interpolate2, ties2);
} else if (isInteger(x)) {
mu = weightedMedian_Integer[idxsType](INTEGER(x), nx, REAL(w), cidxs, nidxs, narm, interpolate2, ties2);
}
/* Return results */
PROTECT(ans = allocVector(REALSXP, 1));
REAL(ans)[0] = mu;
UNPROTECT(1);
return(ans);
} // weightedMedian()
// return just var
SEXP pair_wmw_var(SEXP _X, SEXP _Y, SEXP _method){
int m=length(_X);
int n=length(_Y);
int method=asInteger(_method);// 0,1,2,3,4
double *X=REAL(_X), *Y=REAL(_Y);
SEXP _ans=PROTECT(allocVector(REALSXP, 1));
double *ans=REAL(_ans);
double *xy = malloc((m+n)*sizeof(double));
ans[0]=compute_pair_wmw_Z(X, Y, xy, m, n, 0, method, 0, 1);
free(xy);
//free(unique); free(nties);
UNPROTECT(1);
return _ans;
}
SEXP mongo_simple_command(SEXP mongo_conn, SEXP db, SEXP cmdstr, SEXP arg) {
mongo* conn = _checkMongo(mongo_conn);
const char* _db = CHAR(STRING_ELT(db, 0));
const char* _cmdstr = CHAR(STRING_ELT(cmdstr, 0));
bson out;
int success;
if (TYPEOF(arg) == STRSXP)
success = (mongo_simple_str_command(conn, _db, _cmdstr, CHAR(STRING_ELT(arg, 0)), &out) == MONGO_OK);
else
success = (mongo_simple_int_command(conn, _db, _cmdstr, asInteger(arg), &out) == MONGO_OK);
if (!success) {
return R_NilValue;
}
SEXP ret = _mongo_bson_create(&out);
bson_destroy(&out);
UNPROTECT(3);
return ret;
}
void d_tpsv(SEXP ruplo, SEXP rtrans, SEXP rdiag, SEXP ra, SEXP rx, SEXP rincx)
{
char
uplo = getSymLoc(ruplo),
trans = getTranspose(rtrans),
diag = getUnitTri(rdiag);
double
* a, * x;
int
rowsa, colsa,
nx, incx = asInteger(rincx);
unpackVector(rx, &nx, &x);
unpackMatrix(ra, &rowsa, &colsa, &a);
cublasDtpsv(uplo, trans, diag, rowsa, a, x, incx);
checkCublasError("d_tpsv");
}
bool GenericExpression::eqv(const GenericExpression &other) const
{
{
const SymbolExpression *symA = asSymbol();
const SymbolExpression *symB = other.asSymbol();
if (symA && symB)
{
return *symA == *symB;
}
}
{
const IntegerExpression *intA = asInteger();
const IntegerExpression *intB = other.asInteger();
if (intA && intB)
{
return intA->value() == intB->value();
}
}
{
const CharacterExpression *charA = asCharacter();
const CharacterExpression *charB = other.asCharacter();
if (charA && charB)
{
return charA->value() == charB->value();
}
}
if (isEmptyList() && other.isEmptyList())
{
return true;
}
if (isUnspecified() && other.isUnspecified())
{
return true;
}
return false;
}
SEXP graph_bitarray_Intersect_Attrs(SEXP cmnBits, SEXP fromOneBits,
SEXP fromTwoBits) {
unsigned char *cmn = (unsigned char*) RAW(cmnBits);
unsigned char *fromOne = (unsigned char *) RAW(fromOneBits);
unsigned char *fromTwo = (unsigned char *) RAW(fromTwoBits);
int len = length(cmnBits) * 8;
int i, byteIndex, bitIndex , shft, setIndx = 0;
int nn = asInteger(getAttrib(cmnBits, install("nbitset")));
SEXP from, indx1, indx2, res, namesres;
PROTECT(from = allocVector(INTSXP, nn));
PROTECT(indx1 = allocVector(INTSXP , nn));
PROTECT(indx2 = allocVector(INTSXP , nn));
int from1Indx = 0;
int from2Indx = 0;
for( i =0 ; i < len; i ++) {
byteIndex = i / 8;
bitIndex = i % 8;
shft = 1 << bitIndex;
if(fromOne[byteIndex] & (shft) ) {
from1Indx++;
}
if(fromTwo[byteIndex] & (shft)) {
from2Indx++;
}
if(cmn[byteIndex] & (shft)) {
INTEGER(from)[setIndx] = 0;
INTEGER(indx1)[setIndx] = from1Indx;
INTEGER(indx2)[setIndx] = from2Indx;
setIndx++;
}
}
PROTECT(res = allocVector(VECSXP, 3));
SET_VECTOR_ELT(res, 0, from);
SET_VECTOR_ELT(res, 1, indx1);
SET_VECTOR_ELT(res, 2, indx2);
PROTECT(namesres = allocVector(STRSXP, 3));
SET_STRING_ELT(namesres, 0, mkChar("from"));
SET_STRING_ELT(namesres, 1, mkChar("indx1"));
SET_STRING_ELT(namesres, 2, mkChar("indx2"));
setAttrib(res, R_NamesSymbol, namesres);
UNPROTECT(5);
return(res);
}
/**
* Simulate a sample of random matrices from a Wishart distribution
*
* @param ns Number of samples to generate
* @param nuP Degrees of freedom
* @param scal Positive-definite scale matrix
*
* @return
*/
SEXP
rWishart(SEXP ns, SEXP nuP, SEXP scal)
{
SEXP ans;
int *dims = INTEGER(getAttrib(scal, R_DimSymbol)), info,
n = asInteger(ns), psqr;
double *scCp, *ansp, *tmp, nu = asReal(nuP), one = 1, zero = 0;
if (!isMatrix(scal) || !isReal(scal) || dims[0] != dims[1])
error(_("'scal' must be a square, real matrix"));
if (n <= 0) n = 1;
// allocate early to avoid memory leaks in Callocs below.
PROTECT(ans = alloc3DArray(REALSXP, dims[0], dims[0], n));
psqr = dims[0] * dims[0];
tmp = Calloc(psqr, double);
scCp = Calloc(psqr, double);
Memcpy(scCp, REAL(scal), psqr);
memset(tmp, 0, psqr * sizeof(double));
F77_CALL(dpotrf)("U", &(dims[0]), scCp, &(dims[0]), &info);
if (info)
error(_("'scal' matrix is not positive-definite"));
ansp = REAL(ans);
GetRNGstate();
for (int j = 0; j < n; j++) {
double *ansj = ansp + j * psqr;
std_rWishart_factor(nu, dims[0], 1, tmp);
F77_CALL(dtrmm)("R", "U", "N", "N", dims, dims,
&one, scCp, dims, tmp, dims);
F77_CALL(dsyrk)("U", "T", &(dims[1]), &(dims[1]),
&one, tmp, &(dims[1]),
&zero, ansj, &(dims[1]));
for (int i = 1; i < dims[0]; i++)
for (int k = 0; k < i; k++)
ansj[i + k * dims[0]] = ansj[k + i * dims[0]];
}
PutRNGstate();
Free(scCp); Free(tmp);
UNPROTECT(1);
return ans;
}
// remember only use sexp to return value
SEXP wmw_paired_replicates(SEXP _X, SEXP _Y, SEXP _lenY, SEXP _corr, SEXP _method, SEXP _mc_rep){
int m=length(_X);
double *X0=REAL(_X), *Y0=REAL(_Y);
int *lenY=INTEGER(_lenY);
double Umw;
int i,b;
// int corr=asInteger(_corr);// 0,1,-1,2. correction
// int method=asInteger(_method);// 0,1,2,3,4
int n=0;
for (i = 0; i < m; i++) n+=lenY[i];
double *X = malloc(m*sizeof(double));
double *Y = malloc(n*sizeof(double));
double *xy = malloc((m+n)*sizeof(double));
double *r = malloc((m+n)*sizeof(double));
int mc_rep=asInteger(_mc_rep); // 0: exact perm, 1: z only, 1e4: mc
SEXP _ans=PROTECT(allocVector(REALSXP, mc_rep));
double *ans=REAL(_ans);
// Monte Carlo
for (b=0; b<mc_rep; b++) {
ans[b]=compute_wmw_paired_replicates_stat(X0, Y0, X, Y, lenY, m);
//for (i=0; i<n; i++) PRINTF("%f ", Y[i]); PRINTF("\n");
//for (i=0; i<m; i++) PRINTF("%f ", X[i]); PRINTF("\n");
for (i=0; i<m; i++) xy[i]=X[i];
for (i=0; i<n; i++) xy[i+m]=Y[i];
getrank (m+n, xy, r);
for (i = 0; i < m+n; i++) r[i]+=1; // 0 based in C, 1 based in R
Umw=0;
for (i = 0; i < m; i++) Umw+=r[i];
Umw=Umw - m*(m+1)/2.0;
ans[b]=Umw;
}
//for (b=0; b<mc_rep; b++) PRINTF("%f ", ans[b]); PRINTF("\n");
free(X); free(Y); free(xy); free(r);
UNPROTECT(1);
return _ans;
}
STGM::CSphere convert_C_Sphere(SEXP R_sphere) {
SEXP R_ctr;
int interior=1;
const char *label = "N";
PROTECT(R_ctr = AS_NUMERIC( getListElement( R_sphere, "center")));
int id = asInteger(AS_INTEGER( getListElement( R_sphere, "id")));
double r = asReal(AS_NUMERIC(getListElement(R_sphere, "r")));
if(!isNull(getAttrib(R_sphere, install("label"))))
label = translateChar(asChar(getAttrib(R_sphere, install("label"))));
if(!isNull(getAttrib(R_sphere, install("interior"))))
interior = asLogical(getAttrib(R_sphere, install("interior")));
UNPROTECT(1);
return STGM::CSphere(REAL(R_ctr)[0],REAL(R_ctr)[1],REAL(R_ctr)[2],r,id,label,interior);
}
SEXP PKI_sign_RSA(SEXP what, SEXP sMD, SEXP sKey) {
SEXP res;
int md = asInteger(sMD), type;
EVP_PKEY *key;
RSA *rsa;
unsigned int siglen = sizeof(buf);
switch (md) {
case PKI_MD5:
type = NID_md5;
break;
case PKI_SHA1:
type = NID_sha1;
break;
case PKI_SHA256:
type = NID_sha256;
break;
default:
Rf_error("unsupported hash type");
}
if (TYPEOF(what) != RAWSXP ||
(md == PKI_MD5 && LENGTH(what) != MD5_DIGEST_LENGTH) ||
(md == PKI_SHA1 && LENGTH(what) != SHA_DIGEST_LENGTH) ||
(md == PKI_SHA256 && LENGTH(what) != SHA256_DIGEST_LENGTH))
Rf_error("invalid hash");
if (!inherits(sKey, "private.key"))
Rf_error("key must be RSA private key");
key = (EVP_PKEY*) R_ExternalPtrAddr(sKey);
if (!key)
Rf_error("NULL key");
PKI_init();
if (EVP_PKEY_type(key->type) != EVP_PKEY_RSA)
Rf_error("key must be RSA private key");
rsa = EVP_PKEY_get1_RSA(key);
if (!rsa)
Rf_error("%s", ERR_error_string(ERR_get_error(), NULL));
if (RSA_sign(type,
(const unsigned char*) RAW(what), LENGTH(what),
(unsigned char *) buf, &siglen, rsa) != 1)
Rf_error("%s", ERR_error_string(ERR_get_error(), NULL));
res = allocVector(RAWSXP, siglen);
memcpy(RAW(res), buf, siglen);
return res;
}
/* Wrapper for R */
SEXP R_encode_salt(SEXP csalt_, SEXP log_rounds_){
if(TYPEOF(csalt_) != RAWSXP)
error("Argument csalt must be raw vector of length 16");
if(!isInteger(log_rounds_))
error("Argument log_rounds must be integer");
char ret[64];
Rbyte *csalt = RAW(csalt_);
int csaltlen = LENGTH(csalt_);
int log_rounds = asInteger(log_rounds_);
if (csaltlen != 16)
error("Invalid salt length");
if (log_rounds < 4 || log_rounds > 31)
error("Invalid number of rounds");
encode_salt(ret, csalt, csaltlen, log_rounds);
return mkString(ret);
}
SEXP attribute_hidden do_seq_len(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans;
R_xlen_t len;
checkArity(op, args);
check1argSymbol(args, call, R_LengthOutSymbol);
if(length(CAR(args)) != 1)
warningcall(call, _("first element used of '%s' argument"),
"length.out");
#ifdef LONG_VECTOR_SUPPORT
double dlen = asReal(CAR(args));
if(!R_FINITE(dlen) || dlen < 0)
errorcall(call, _("argument must be coercible to non-negative integer"));
len = (R_xlen_t) dlen;
#else
len = asInteger(CAR(args));
if(len == NA_INTEGER || len < 0)
errorcall(call, _("argument must be coercible to non-negative integer"));
#endif
#ifdef LONG_VECTOR_SUPPORT
if (len > INT_MAX) {
ans = allocVector(REALSXP, len);
double *p = REAL(ans);
for(R_xlen_t i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
p[i] = (double) (i+1);
}
} else
#endif
{
ans = allocVector(INTSXP, len);
int *p = INTEGER(ans);
for(int i = 0; i < len; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
p[i] = i+1;
}
}
return ans;
}
SEXP attribute_hidden do_quit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
const char *tmp;
SA_TYPE ask=SA_DEFAULT;
int status, runLast;
/* if there are any browser contexts active don't quit */
if(countContexts(CTXT_BROWSER, 1)) {
warning(_("cannot quit from browser"));
return R_NilValue;
}
if( !isString(CAR(args)) )
errorcall(call, _("one of \"yes\", \"no\", \"ask\" or \"default\" expected."));
tmp = CHAR(STRING_ELT(CAR(args), 0)); /* ASCII */
if( !strcmp(tmp, "ask") ) {
ask = SA_SAVEASK;
if(!R_Interactive)
warning(_("save=\"ask\" in non-interactive use: command-line default will be used"));
} else if( !strcmp(tmp, "no") )
ask = SA_NOSAVE;
else if( !strcmp(tmp, "yes") )
ask = SA_SAVE;
else if( !strcmp(tmp, "default") )
ask = SA_DEFAULT;
else
errorcall(call, _("unrecognized value of 'save'"));
status = asInteger(CADR(args));
if (status == NA_INTEGER) {
warning(_("invalid 'status', 0 assumed"));
runLast = 0;
}
runLast = asLogical(CADDR(args));
if (runLast == NA_LOGICAL) {
warning(_("invalid 'runLast', FALSE assumed"));
runLast = 0;
}
/* run the .Last function. If it gives an error, will drop back to main
loop. */
R_CleanUp(ask, status, runLast);
exit(0);
/*NOTREACHED*/
}
// get ptids for a node
SEXP cGetNdPtids(SEXP id_, SEXP prids_) {
SEXP res_ptids;
R_xlen_t nids = xlength(prids_);
int id = asInteger(id_);
// vector of internal node prids
// duplicate, potential to be a C generated object via cFindPrids
// without duplicating, this function will modify other vectors
// in the R environment
// Protect duplicate again, no longer argument
int* prids = INTEGER(PROTECT(duplicate(prids_)));
PROTECT(res_ptids=allocVector(INTSXP, nids));
int *pres = INTEGER(res_ptids);
int qrys[nids+1];
// init res_ptids and qrys
memset(pres, 0, nids * sizeof(int));
memset(qrys, -1, (nids + 1) * sizeof(int));
int qry=id;
int ni=0;
int nqrys=0;
R_xlen_t i;
while(qry != -1) {
// remove qry from prids
for(i=0;i<nids; i++) {
if(qry == (i + 1)) {
prids[i] = -1;
}
}
// search for qry in prids
for(i=0;i<nids; i++) {
if(qry == prids[i]) {
pres[i] = 1;
nqrys = nqrys + 1;
qrys[nqrys] = i + 1;
}
}
// update qry
ni = ni + 1;
qry = qrys[ni];
}
UNPROTECT(2);
return res_ptids;
}
