void SEXP_2_NimArrInt (SEXP rValues, NimArrBase<int> &NimArrInt){
int rLength = LENGTH(rValues);
if(rLength != NimArrInt.size() ) {
PRINTF("Warning: R object of different size than NimArrInt!\n");
return;
}
if(isInteger(rValues) ) {
for(int i = 0; i < rLength; i++)
NimArrInt[i] = INTEGER(rValues)[i];
}
else if(isReal(rValues) ) {
for(int i = 0; i < rLength; i++)
NimArrInt[i] = REAL(rValues)[i];
}
else
PRINTF("WARNING: class of R object not recognized. Should be numeric or integer\n");
return;
}
static int num_vals_args(int firstarg, int lastarg, char *argv[],
double valptr[], int max_n_vals )
{
int argno, valndx;
double cur_val;
for (argno = firstarg; argno < lastarg; argno++)
if (isReal( argv[ argno ] )) {
cur_val = stringReal( argv[ argno ] );
valndx = argno-firstarg;
if (valndx < max_n_vals)
valptr[ valndx ] = cur_val;
}
else {
Werrprintf( "%s: invalid argument '%s'", argv[ 0 ], argv[ argno ] );
return( -1 );
}
return( lastarg-firstarg );
}
NumericLiteral NumericLiteral::operator*(const NumericLiteral &l) const {
/* if one of the arguments is real, we must return a
* real literal with the result of the operation in the numerator attribute
* and set the denominator to 1 */
if (isReal() || l.isReal()) {
NumericLiteral tmp = NumericLiteral(
numerator*l.numerator,
denominator * l.denominator
);
tmp.numerator = tmp.numerator/tmp.denominator;
tmp.denominator = 1;
return tmp;
}
/* In general, we return a new numeric literal with the normal multiplication operation */
return NumericLiteral(
numerator*l.numerator,
denominator * l.denominator
);
}
SEXP in_memsize(SEXP ssize)
{
SEXP ans;
int maxmem = NA_LOGICAL;
if(isLogical(ssize))
maxmem = asLogical(ssize);
else if(isReal(ssize)) {
R_size_t newmax;
double mem = asReal(ssize);
if (!R_FINITE(mem))
error(_("incorrect argument"));
#ifdef LEA_MALLOC
#ifndef WIN64
if(mem >= 4096)
error(_("don't be silly!: your machine has a 4Gb address limit"));
#endif
newmax = mem * 1048576.0;
if (newmax < R_max_memory)
warning(_("cannot decrease memory limit: ignored"));
else
R_max_memory = newmax;
#endif
} else
error(_("incorrect argument"));
PROTECT(ans = allocVector(REALSXP, 1));
#ifdef LEA_MALLOC
if(maxmem == NA_LOGICAL)
REAL(ans)[0] = R_max_memory;
else if(maxmem)
REAL(ans)[0] = mallinfo().usmblks;
else
REAL(ans)[0] = mallinfo().uordblks;
REAL(ans)[0] /= 1048576.0;
#else
REAL(ans)[0] = NA_REAL;
#endif
UNPROTECT(1);
return ans;
}
SEXP matrix_smooth(SEXP mat)
{
#define ij(i, j) ((i) + (ni) * (j))
/* Note: the 2d data are stored in column order */
SEXP res;
int ni = INTEGER(GET_DIM(mat))[0];
int nj = INTEGER(GET_DIM(mat))[1];
int i, j;
double *matp, *resp;
if (!isMatrix(mat))
error("'mat' must be a matrix");
if (!isReal(mat))
error("'mat' must be numeric, not integer");
matp = REAL(mat);
if (length(mat) != ni * nj)
error("'ni'*'nj' must equal number of elements in 'mat'");
PROTECT(res = allocMatrix(REALSXP, ni, nj));
resp = REAL(res);
for (i = 0; i < ni*nj; i++)
resp[i] = 99.99;
// copy edges (FIXME: coiuld use 1D smoother here)
for (j = 0; j < nj; j++) {
resp[ij(0, j)] = matp[ij(0, j)];
resp[ij(ni-1, j)] = matp[ij(ni-1, j)];
}
for (i = 0; i < ni; i++) {
resp[ij(i, 0)] = matp[ij(i, 0)];
resp[ij(i, nj-1)] = matp[ij(i, nj-1)];
}
// smooth middle
for (i = 1; i < ni - 1; i++)
for (j = 1; j < nj - 1; j++)
resp[ij(i, j)] = (2.0*matp[ij(i, j)] +
matp[ij(i-1, j)] +
matp[ij(i+1, j)] +
matp[ij(i, j-1)] +
matp[ij(i, j+1)]) / 6.0;
UNPROTECT(1);
return(res);
#undef ix
}
SEXP d2mpfr1_list(SEXP x, SEXP prec, SEXP rnd_mode)
{
int nx = LENGTH(x), np = LENGTH(prec),
n = (nx == 0 || np == 0) ? 0 : imax2(nx, np),
nprot = 1;
SEXP val = PROTECT(allocVector(VECSXP, n));
if(nx > 0) {
mpfr_rnd_t rnd = R_rnd2MP(rnd_mode);
if(!isReal(x)) { PROTECT(x = coerceVector(x, REALSXP)); nprot++; }
if(!isInteger(prec)) { PROTECT(prec = coerceVector(prec, INTSXP)); nprot++; }
double *dx = REAL(x);
int *iprec = INTEGER(prec);
for(int i = 0; i < n; i++) {
/* FIXME: become more efficient by doing R_..._2R_init() only once*/
SET_VECTOR_ELT(val, i, d2mpfr1_(dx[i % nx], iprec[i % np], rnd));
}
}
UNPROTECT(nprot);
return val;
}
/* This does *not* work: gives *empty* .Data slot [bug in NEW_OBJECT()? ] */
SEXP d2mpfr(SEXP x, SEXP prec)
{
int i_prec = asInteger(prec),
nx = LENGTH(x), np = LENGTH(prec),
n = (nx == 0 || np == 0) ? 0 : imax2(nx, np),
nprot = 1;
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("mpfr"))),
lis = ALLOC_SLOT(val, Rmpfr_Data_Sym, VECSXP, n);
double *dx;
if(!isReal(x)) { PROTECT(x = coerceVector(x, REALSXP)); nprot++; }
REprintf("d2mpfr(x, prec): length(x) = %d, prec = %d -> length(lis) = %d\n",
nx, i_prec, LENGTH(lis));
dx = REAL(x);
for(int i = 0; i < n; i++) {
SET_VECTOR_ELT(lis, i, duplicate(d2mpfr1_(dx [i % nx],
i_prec [i % np])));
}
UNPROTECT(nprot);
return val;
}
static PyObject *
Pympany_digits(PyObject *self, PyObject *args)
{
PyObject *temp;
if (PyTuple_GET_SIZE(args) == 0) {
TYPE_ERROR("digits() requires at least one argument");
return NULL;
}
temp = PyTuple_GET_ITEM(args, 0);
if (isInteger(temp))
return Pympz_digits(self, args);
else if (isRational(temp))
return Pympq_digits(self, args);
#ifdef WITHMPFR
else if (isReal(temp))
return Pympfr_digits(self, args);
#endif
TYPE_ERROR("digits() not supported");
return NULL;
}
NumericLiteral NumericLiteral::operator-(const NumericLiteral &l) const {
/* if one is a real literal and the other a rational literal, we must return a
* real literal with the result of the operation in the numerator attribute
* and set the denominator to 1 */
if (isReal() || l.isReal()) {
NumericLiteral tmp = NumericLiteral(
numerator*l.denominator - l.numerator*denominator,
denominator * l.denominator
);
tmp.numerator = tmp.numerator/tmp.denominator;
tmp.denominator = 1;
return tmp;
/* It was also possible to return a rational or an integer (after simplification)
* but the it's clearly specified in the project that difference with real always return a real literal */
}
/* In general, we return a new numeric literal with the normal plus operation */
return NumericLiteral(
numerator*l.denominator - l.numerator*denominator,
denominator * l.denominator
);
}
BigInteger<BASE>& BigInteger<BASE>::operator<<=(int shift) {
if(!isReal() || isNull())
return *this;
if(shift > 0) {
int size = capacity();
int realsize = realSize();
while(realsize + shift > size)
size = expand();
if(realsize == 1 && _a[0] == 0)
return *this;
for(int index = realsize-1; index >= 0; --index)
_a[index+shift] = _a[index];
for(int index = shift-1; index >= 0; --index)
_a[index] = 0;
updRealSize(shift);
return *this;
}
else if(shift == 0)
return *this;
else
return (*this)>>=(-shift);
}
void KviKvsVariant::castToNumber(KviKvsNumber & number) const
{
if(!m_pData)
{
number.m_u.iInt = 0;
number.m_type = KviKvsNumber::Integer;
return;
}
if(isInteger())
{
number.m_u.iInt = m_pData->m_u.iInt;
number.m_type = KviKvsNumber::Integer;
return;
}
if(isReal())
{
number.m_u.dReal = *(m_pData->m_u.pReal);
number.m_type = KviKvsNumber::Real;
return;
}
if(asInteger(number.m_u.iInt))
{
number.m_type = KviKvsNumber::Integer;
return;
}
if(asReal(number.m_u.dReal))
{
number.m_type = KviKvsNumber::Real;
return;
}
castToInteger(number.m_u.iInt);
number.m_type = KviKvsNumber::Integer;
}
static int check_unlock_args(int argc, char*argv[], int *force )
{
int badf, ival;
*force = 0;
ival = 0;
badf = ((argc != 2) && (argc != 3));
if ( !badf )
{
if ( !isReal( argv[ 1 ] ) ) {
if ( strncmp( "exp", argv[ 1 ], 3 ) == 0 &&
isdigit( *(argv[ 1 ] + 3) ) )
ival = atoi( argv[ 1 ] + 3 );
else
badf = 1;
}
else
ival = atoi( argv[ 1 ] );
}
if ((argc == 3) && (strcmp("force",argv[2]) == 0))
*force = 1;
if ( badf ) {
Werrprintf( "usage - %s(exp#) or %s(exp#,'force')",
argv[ 0 ], argv[0] );
return( -1 );
}
if (ival < 1 || ival > MAXEXPS) {
Werrprintf( "%s: %d is not a valid experiment number",
argv[ 0 ], ival
);
return( -1 );
}
return( ival );
}
matrix_info check_matrix(SEXP matrix) {
int type;
if (isReal(matrix)) {
type=0;
} else if (isInteger(matrix)) {
type=1;
} else if (isLogical(matrix)) {
type=2;
} else {
throw std::runtime_error("matrix must be integer or double-precision");
}
SEXP dims=getAttrib(matrix, R_DimSymbol);
if (!isInteger(dims) || LENGTH(dims)!=2) {
throw std::runtime_error("dimensions of the matrix should be an integer vector of length 2");
}
int nrow=INTEGER(dims)[0], ncol=INTEGER(dims)[1];
if (LENGTH(matrix)!=nrow*ncol) {
throw std::runtime_error("recorded dimensions of the matrix are not consistent with its length");
}
matrix_info output(nrow, ncol, type>0);
switch (type) {
case 0:
output.dptr=REAL(matrix);
break;
case 1:
output.iptr=INTEGER(matrix);
break;
case 2:
output.iptr=LOGICAL(matrix);
break;
}
return output;
}
SEXP rowRanges(SEXP x, SEXP dim, SEXP what, SEXP naRm, SEXP hasNA) {
SEXP ans = NILSXP, ans2 = NILSXP;
int *mins, *maxs;
double *mins2, *maxs2;
int *is_counted, all_counted = 0;
int what2, narm, hasna;
R_xlen_t nrow, ncol, ii;
/* Argument 'x' and 'dim': */
assertArgMatrix(x, dim, (R_TYPE_INT | R_TYPE_REAL), "x");
nrow = INTEGER(dim)[0];
ncol = INTEGER(dim)[1];
/* Argument 'what': */
if (length(what) != 1)
error("Argument 'what' must be a single number.");
if (!isNumeric(what))
error("Argument 'what' must be a numeric number.");
what2 = asInteger(what);
if (what2 < 0 || what2 > 2)
error("Invalid value of 'what': %d", what2);
/* Argument 'naRm': */
narm = asLogicalNoNA(naRm, "na.rm");
/* Argument 'hasNA': */
hasna = asLogicalNoNA(hasNA, "hasNA");
is_counted = (int *) R_alloc(nrow, sizeof(int));
if (isReal(x)) {
if (what2 == 2) {
PROTECT(ans = allocMatrix(REALSXP, nrow, 2));
} else {
PROTECT(ans = allocVector(REALSXP, nrow));
}
rowRanges_Real(REAL(x), nrow, ncol, what2, narm, hasna, REAL(ans), is_counted);
UNPROTECT(1);
} else if (isInteger(x)) {
if (what2 == 2) {
PROTECT(ans = allocMatrix(INTSXP, nrow, 2));
} else {
PROTECT(ans = allocVector(INTSXP, nrow));
}
rowRanges_Integer(INTEGER(x), nrow, ncol, what2, narm, hasna, INTEGER(ans), is_counted);
/* Any entries with zero non-missing values? */
all_counted = 1;
for (ii=0; ii < nrow; ii++) {
if (!is_counted[ii]) {
all_counted = 0;
break;
}
}
if (!all_counted) {
/* Handle zero non-missing values */
/* Instead of return INTSXP, we must return REALSXP (to hold -Inf, and Inf) */
if (what2 == 0) {
PROTECT(ans2 = allocVector(REALSXP, nrow));
mins = INTEGER(ans);
mins2 = REAL(ans2);
for (ii=0; ii < nrow; ii++) {
if (is_counted[ii]) {
mins2[ii] = (double)mins[ii];
} else {
mins2[ii] = R_PosInf;
}
}
UNPROTECT(1); /* ans2 */
} else if (what2 == 1) {
PROTECT(ans2 = allocVector(REALSXP, nrow));
maxs = INTEGER(ans);
maxs2 = REAL(ans2);
for (ii=0; ii < nrow; ii++) {
if (is_counted[ii]) {
maxs2[ii] = (double)maxs[ii];
} else {
maxs2[ii] = R_NegInf;
}
}
UNPROTECT(1); /* ans2 */
} else if (what2 == 2) {
PROTECT(ans2 = allocMatrix(REALSXP, nrow, 2));
mins = INTEGER(ans);
maxs = &INTEGER(ans)[nrow];
mins2 = REAL(ans2);
maxs2 = &REAL(ans2)[nrow];
for (ii=0; ii < nrow; ii++) {
if (is_counted[ii]) {
mins2[ii] = (double)mins[ii];
maxs2[ii] = (double)maxs[ii];
} else {
mins2[ii] = R_PosInf;
maxs2[ii] = R_NegInf;
}
}
UNPROTECT(1); /* ans2 */
}
ans = ans2;
}
UNPROTECT(1); /* ans */
}
return(ans);
} // rowRanges()
/* This is for all cases with a single index, including 1D arrays and
matrix indexing of arrays */
static SEXP VectorSubset(SEXP x, SEXP s, SEXP call)
{
R_xlen_t n;
int mode;
R_xlen_t stretch = 1;
SEXP indx, result, attrib, nattrib;
if (s == R_MissingArg) return duplicate(x);
PROTECT(s);
attrib = getAttrib(x, R_DimSymbol);
/* Check to see if we have special matrix subscripting. */
/* If we do, make a real subscript vector and protect it. */
if (isMatrix(s) && isArray(x) && ncols(s) == length(attrib)) {
if (isString(s)) {
s = strmat2intmat(s, GetArrayDimnames(x), call);
UNPROTECT(1);
PROTECT(s);
}
if (isInteger(s) || isReal(s)) {
s = mat2indsub(attrib, s, call);
UNPROTECT(1);
PROTECT(s);
}
}
/* Convert to a vector of integer subscripts */
/* in the range 1:length(x). */
PROTECT(indx = makeSubscript(x, s, &stretch, call));
n = XLENGTH(indx);
/* Allocate the result. */
mode = TYPEOF(x);
/* No protection needed as ExtractSubset does not allocate */
result = allocVector(mode, n);
if (mode == VECSXP || mode == EXPRSXP)
/* we do not duplicate the values when extracting the subset,
so to be conservative mark the result as NAMED = 2 */
SET_NAMED(result, 2);
PROTECT(result = ExtractSubset(x, result, indx, call));
if (result != R_NilValue) {
if (
((attrib = getAttrib(x, R_NamesSymbol)) != R_NilValue) ||
( /* here we might have an array. Use row names if 1D */
isArray(x) && LENGTH(getAttrib(x, R_DimNamesSymbol)) == 1 &&
(attrib = getAttrib(x, R_DimNamesSymbol)) != R_NilValue &&
(attrib = GetRowNames(attrib)) != R_NilValue
)
) {
PROTECT(attrib);
nattrib = allocVector(TYPEOF(attrib), n);
PROTECT(nattrib); /* seems unneeded */
nattrib = ExtractSubset(attrib, nattrib, indx, call);
setAttrib(result, R_NamesSymbol, nattrib);
UNPROTECT(2); /* attrib, nattrib */
}
if ((attrib = getAttrib(x, R_SrcrefSymbol)) != R_NilValue &&
TYPEOF(attrib) == VECSXP) {
nattrib = allocVector(VECSXP, n);
PROTECT(nattrib); /* seems unneeded */
nattrib = ExtractSubset(attrib, nattrib, indx, call);
setAttrib(result, R_SrcrefSymbol, nattrib);
UNPROTECT(1);
}
/* FIXME: this is wrong, because the slots are gone, so result is an invalid object of the S4 class! JMC 3/3/09 */
#ifdef _S4_subsettable
if(IS_S4_OBJECT(x)) { /* e.g. contains = "list" */
setAttrib(result, R_ClassSymbol, getAttrib(x, R_ClassSymbol));
SET_S4_OBJECT(result);
}
#endif
}
UNPROTECT(3);
return result;
}
bool ASTType::isNumeric() const
{
return isInt() || isReal();
}
static SEXP baseCallback(GEevent task, pGEDevDesc dd, SEXP data)
{
GESystemDesc *sd;
baseSystemState *bss, *bss2;
SEXP result = R_NilValue;
switch (task) {
case GE_FinaliseState:
/* called from unregisterOne */
sd = dd->gesd[baseRegisterIndex];
free(sd->systemSpecific);
sd->systemSpecific = NULL;
break;
case GE_InitState:
{
/* called from registerOne */
pDevDesc dev;
GPar *ddp;
sd = dd->gesd[baseRegisterIndex];
dev = dd->dev;
bss = sd->systemSpecific = malloc(sizeof(baseSystemState));
/* Bail out if necessary */
if (!bss) return result;
/* Make sure initialized, or valgrind may complain. */
memset(bss, 0, sizeof(baseSystemState));
ddp = &(bss->dp);
GInit(ddp);
/* For some things, the device sets the starting value at least. */
ddp->ps = dev->startps;
ddp->col = ddp->fg = dev->startcol;
ddp->bg = dev->startfill;
ddp->font = dev->startfont;
ddp->lty = dev->startlty;
ddp->gamma = dev->startgamma;
/* Initialise the gp settings too: formerly in addDevice. */
copyGPar(ddp, &(bss->gp));
GReset(dd);
/*
* The device has not yet received any base output
*/
bss->baseDevice = FALSE;
/* Indicate success */
result = R_BlankString;
break;
}
case GE_CopyState:
{
/* called from GEcopyDisplayList */
pGEDevDesc curdd = GEcurrentDevice();
bss = dd->gesd[baseRegisterIndex]->systemSpecific;
bss2 = curdd->gesd[baseRegisterIndex]->systemSpecific;
copyGPar(&(bss->dpSaved), &(bss2->dpSaved));
restoredpSaved(curdd);
copyGPar(&(bss2->dp), &(bss2->gp));
GReset(curdd);
break;
}
case GE_SaveState:
/* called from GEinitDisplayList */
bss = dd->gesd[baseRegisterIndex]->systemSpecific;
copyGPar(&(bss->dp), &(bss->dpSaved));
break;
case GE_RestoreState:
/* called from GEplayDisplayList */
bss = dd->gesd[baseRegisterIndex]->systemSpecific;
restoredpSaved(dd);
copyGPar(&(bss->dp), &(bss->gp));
GReset(dd);
break;
case GE_SaveSnapshotState:
/* called from GEcreateSnapshot */
bss = dd->gesd[baseRegisterIndex]->systemSpecific;
/* Changed from INTSXP in 2.7.0: but saved graphics lists
are protected by an R version number */
PROTECT(result = allocVector(RAWSXP, sizeof(GPar)));
copyGPar(&(bss->dpSaved), (GPar*) RAW(result));
UNPROTECT(1);
break;
case GE_RestoreSnapshotState:
/* called from GEplaySnapshot */
bss = dd->gesd[baseRegisterIndex]->systemSpecific;
copyGPar((GPar*) RAW(data), &(bss->dpSaved));
restoredpSaved(dd);
copyGPar(&(bss->dp), &(bss->gp));
GReset(dd);
break;
case GE_CheckPlot:
/* called from GEcheckState:
Check that the current plotting state is "valid"
*/
bss = dd->gesd[baseRegisterIndex]->systemSpecific;
result = ScalarLogical(bss->baseDevice ?
(bss->gp.state == 1) && bss->gp.valid :
TRUE);
break;
case GE_ScalePS:
{
/* called from GEhandleEvent in devWindows.c */
GPar *ddp, *ddpSaved;
bss = dd->gesd[baseRegisterIndex]->systemSpecific;
ddp = &(bss->dp);
ddpSaved = &(bss->dpSaved);
if (isReal(data) && LENGTH(data) == 1) {
double rf = REAL(data)[0];
ddp->scale *= rf;
/* Modify the saved settings so this effects display list too */
ddpSaved->scale *= rf;
} else
error("event 'GE_ScalePS' requires a single numeric value");
break;
}
}
return result;
}
SEXP lapack_qr(SEXP Xin, SEXP tl)
{
SEXP ans, Givens, Gcpy, nms, pivot, qraux, X;
int i, n, nGivens = 0, p, trsz, *Xdims, rank;
double rcond = 0., tol = asReal(tl), *work;
if (!(isReal(Xin) & isMatrix(Xin)))
error(_("X must be a real (numeric) matrix"));
if (tol < 0.) error(_("tol, given as %g, must be non-negative"), tol);
if (tol > 1.) error(_("tol, given as %g, must be <= 1"), tol);
ans = PROTECT(allocVector(VECSXP,5));
SET_VECTOR_ELT(ans, 0, X = duplicate(Xin));
Xdims = INTEGER(coerceVector(getAttrib(X, R_DimSymbol), INTSXP));
n = Xdims[0]; p = Xdims[1];
SET_VECTOR_ELT(ans, 2, qraux = allocVector(REALSXP, (n < p) ? n : p));
SET_VECTOR_ELT(ans, 3, pivot = allocVector(INTSXP, p));
for (i = 0; i < p; i++) INTEGER(pivot)[i] = i + 1;
trsz = (n < p) ? n : p; /* size of triangular part of decomposition */
rank = trsz;
Givens = PROTECT(allocVector(VECSXP, rank - 1));
setAttrib(ans, R_NamesSymbol, nms = allocVector(STRSXP, 5));
SET_STRING_ELT(nms, 0, mkChar("qr"));
SET_STRING_ELT(nms, 1, mkChar("rank"));
SET_STRING_ELT(nms, 2, mkChar("qraux"));
SET_STRING_ELT(nms, 3, mkChar("pivot"));
SET_STRING_ELT(nms, 4, mkChar("Givens"));
if (n > 0 && p > 0) {
int info, *iwork, lwork;
double *xpt = REAL(X), tmp;
lwork = -1;
F77_CALL(dgeqrf)(&n, &p, xpt, &n, REAL(qraux), &tmp, &lwork, &info);
if (info)
error(_("First call to dgeqrf returned error code %d"), info);
lwork = (int) tmp;
work = (double *) R_alloc((lwork < 3*trsz) ? 3*trsz : lwork,
sizeof(double));
F77_CALL(dgeqrf)(&n, &p, xpt, &n, REAL(qraux), work, &lwork, &info);
if (info)
error(_("Second call to dgeqrf returned error code %d"), info);
iwork = (int *) R_alloc(trsz, sizeof(int));
F77_CALL(dtrcon)("1", "U", "N", &rank, xpt, &n, &rcond,
work, iwork, &info);
if (info)
error(_("Lapack routine dtrcon returned error code %d"), info);
while (rcond < tol) { /* check diagonal elements */
double minabs = (xpt[0] < 0.) ? -xpt[0]: xpt[0];
int jmin = 0;
for (i = 1; i < rank; i++) {
double el = xpt[i*(n+1)];
el = (el < 0.) ? -el: el;
if (el < minabs) {
jmin = i;
minabs = el;
}
}
if (jmin < (rank - 1)) {
SET_VECTOR_ELT(Givens, nGivens, getGivens(xpt, n, jmin, rank));
nGivens++;
}
rank--;
F77_CALL(dtrcon)("1", "U", "N", &rank, xpt, &n, &rcond,
work, iwork, &info);
if (info)
error(_("Lapack routine dtrcon returned error code %d"), info);
}
}
SET_VECTOR_ELT(ans, 4, Gcpy = allocVector(VECSXP, nGivens));
for (i = 0; i < nGivens; i++)
SET_VECTOR_ELT(Gcpy, i, VECTOR_ELT(Givens, i));
SET_VECTOR_ELT(ans, 1, ScalarInteger(rank));
setAttrib(ans, install("useLAPACK"), ScalarLogical(1));
setAttrib(ans, install("rcond"), ScalarReal(rcond));
UNPROTECT(2);
return ans;
}
SEXP attribute_hidden do_cmathfuns(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x, y = R_NilValue; /* -Wall*/
R_xlen_t i, n;
checkArity(op, args);
check1arg(args, call, "z");
if (DispatchGroup("Complex", call, op, args, env, &x))
return x;
x = CAR(args);
if (isComplex(x)) {
n = XLENGTH(x);
switch(PRIMVAL(op)) {
case 1: /* Re */
y = allocVector(REALSXP, n);
for(i = 0 ; i < n ; i++)
REAL(y)[i] = COMPLEX(x)[i].r;
break;
case 2: /* Im */
y = allocVector(REALSXP, n);
for(i = 0 ; i < n ; i++)
REAL(y)[i] = COMPLEX(x)[i].i;
break;
case 3: /* Mod */
case 6: /* abs */
y = allocVector(REALSXP, n);
for(i = 0 ; i < n ; i++)
#if HAVE_CABS
REAL(y)[i] = cabs(C99_COMPLEX2(x, i));
#else
REAL(y)[i] = hypot(COMPLEX(x)[i].r, COMPLEX(x)[i].i);
#endif
break;
case 4: /* Arg */
y = allocVector(REALSXP, n);
for(i = 0 ; i < n ; i++)
#if HAVE_CARG
REAL(y)[i] = carg(C99_COMPLEX2(x, i));
#else
REAL(y)[i] = atan2(COMPLEX(x)[i].i, COMPLEX(x)[i].r);
#endif
break;
case 5: /* Conj */
y = NO_REFERENCES(x) ? x : allocVector(CPLXSXP, n);
for(i = 0 ; i < n ; i++) {
COMPLEX(y)[i].r = COMPLEX(x)[i].r;
COMPLEX(y)[i].i = -COMPLEX(x)[i].i;
}
break;
}
}
else if(isNumeric(x)) { /* so no complex numbers involved */
n = XLENGTH(x);
if(isReal(x)) PROTECT(x);
else PROTECT(x = coerceVector(x, REALSXP));
y = NO_REFERENCES(x) ? x : allocVector(REALSXP, n);
switch(PRIMVAL(op)) {
case 1: /* Re */
case 5: /* Conj */
for(i = 0 ; i < n ; i++)
REAL(y)[i] = REAL(x)[i];
break;
case 2: /* Im */
for(i = 0 ; i < n ; i++)
REAL(y)[i] = 0.0;
break;
case 4: /* Arg */
for(i = 0 ; i < n ; i++)
if(ISNAN(REAL(x)[i]))
REAL(y)[i] = REAL(x)[i];
else if (REAL(x)[i] >= 0)
REAL(y)[i] = 0;
else
REAL(y)[i] = M_PI;
break;
case 3: /* Mod */
case 6: /* abs */
for(i = 0 ; i < n ; i++)
REAL(y)[i] = fabs(REAL(x)[i]);
break;
}
UNPROTECT(1);
}
else errorcall(call, _("non-numeric argument to function"));
if (x != y && ATTRIB(x) != R_NilValue) {
PROTECT(x);
PROTECT(y);
DUPLICATE_ATTRIB(y, x);
UNPROTECT(2);
}
return y;
}
RealType::RealType(const Type& t) throw(IllegalArgumentException) :
Type(t) {
PrettyCheckArgument(isNull() || isReal(), this);
}
SEXP scdd_f(SEXP m, SEXP h, SEXP roworder, SEXP adjacency,
SEXP inputadjacency, SEXP incidence, SEXP inputincidence)
{
int i, j, k;
GetRNGstate();
if (! isMatrix(m))
error("'m' must be matrix");
if (! isLogical(h))
error("'h' must be logical");
if (! isString(roworder))
error("'roworder' must be character");
if (! isLogical(adjacency))
error("'adjacency' must be logical");
if (! isLogical(inputadjacency))
error("'inputadjacency' must be logical");
if (! isLogical(incidence))
error("'incidence' must be logical");
if (! isLogical(inputincidence))
error("'inputincidence' must be logical");
if (LENGTH(h) != 1)
error("'h' must be scalar");
if (LENGTH(roworder) != 1)
error("'roworder' must be scalar");
if (LENGTH(adjacency) != 1)
error("'adjacency' must be scalar");
if (LENGTH(inputadjacency) != 1)
error("'inputadjacency' must be scalar");
if (LENGTH(incidence) != 1)
error("'incidence' must be scalar");
if (LENGTH(inputincidence) != 1)
error("'inputincidence' must be scalar");
if (! isReal(m))
error("'m' must be double");
SEXP m_dim;
PROTECT(m_dim = getAttrib(m, R_DimSymbol));
int nrow = INTEGER(m_dim)[0];
int ncol = INTEGER(m_dim)[1];
UNPROTECT(1);
#ifdef BLATHER
printf("nrow = %d\n", nrow);
printf("ncol = %d\n", ncol);
#endif /* BLATHER */
if ((! LOGICAL(h)[0]) && nrow <= 0)
error("no rows in 'm', not allowed for V-representation");
if (ncol <= 2)
error("no cols in m[ , - c(1, 2)]");
for (i = 0; i < nrow * ncol; i++)
if (! R_finite(REAL(m)[i]))
error("'m' not finite-valued");
for (i = 0; i < nrow; i++) {
double foo = REAL(m)[i];
if (! (foo == 0.0 || foo == 1.0))
error("column one of 'm' not zero-or-one valued");
}
if (! LOGICAL(h)[0])
for (i = nrow; i < 2 * nrow; i++) {
double foo = REAL(m)[i];
if (! (foo == 0.0 || foo == 1.0))
error("column two of 'm' not zero-or-one valued");
}
ddf_set_global_constants();
myfloat value;
ddf_init(value);
ddf_MatrixPtr mf = ddf_CreateMatrix(nrow, ncol - 1);
/* note our matrix has one more column than Fukuda's */
/* representation */
if(LOGICAL(h)[0])
mf->representation = ddf_Inequality;
else
mf->representation = ddf_Generator;
mf->numbtype = ddf_Real;
/* linearity */
for (i = 0; i < nrow; i++) {
double foo = REAL(m)[i];
if (foo == 1.0)
set_addelem(mf->linset, i + 1);
/* note conversion from zero-origin to one-origin indexing */
}
/* matrix */
for (j = 1, k = nrow; j < ncol; j++)
for (i = 0; i < nrow; i++, k++) {
ddf_set_d(value, REAL(m)[k]);
ddf_set(mf->matrix[i][j - 1], value);
/* note our matrix has one more column than Fukuda's */
}
ddf_RowOrderType strategy = ddf_LexMin;
const char *row_str = CHAR(STRING_ELT(roworder, 0));
if(strcmp(row_str, "maxindex") == 0)
strategy = ddf_MaxIndex;
else if(strcmp(row_str, "minindex") == 0)
strategy = ddf_MinIndex;
else if(strcmp(row_str, "mincutoff") == 0)
strategy = ddf_MinCutoff;
else if(strcmp(row_str, "maxcutoff") == 0)
strategy = ddf_MaxCutoff;
else if(strcmp(row_str, "mixcutoff") == 0)
strategy = ddf_MixCutoff;
else if(strcmp(row_str, "lexmin") == 0)
strategy = ddf_LexMin;
else if(strcmp(row_str, "lexmax") == 0)
strategy = ddf_LexMax;
else if(strcmp(row_str, "randomrow") == 0)
strategy = ddf_RandomRow;
else
error("roworder not recognized");
ddf_ErrorType err = ddf_NoError;
ddf_PolyhedraPtr poly = ddf_DDMatrix2Poly2(mf, strategy, &err);
if (poly->child != NULL && poly->child->CompStatus == ddf_InProgress) {
ddf_FreeMatrix(mf);
ddf_FreePolyhedra(poly);
ddf_clear(value);
ddf_free_global_constants();
error("Computation failed, floating-point arithmetic problem\n");
}
if (err != ddf_NoError) {
rrf_WriteErrorMessages(err);
ddf_FreeMatrix(mf);
ddf_FreePolyhedra(poly);
ddf_clear(value);
ddf_free_global_constants();
error("failed");
}
ddf_MatrixPtr aout = NULL;
if (poly->representation == ddf_Inequality)
aout = ddf_CopyGenerators(poly);
else if (poly->representation == ddf_Generator)
aout = ddf_CopyInequalities(poly);
else
error("Cannot happen! poly->representation no good\n");
if (aout == NULL)
error("Cannot happen! aout no good\n");
int mrow = aout->rowsize;
int mcol = aout->colsize;
if (mcol + 1 != ncol)
error("Cannot happen! computed matrix has wrong number of columns");
#ifdef BLATHER
printf("mrow = %d\n", mrow);
printf("mcol = %d\n", mcol);
#endif /* BLATHER */
SEXP bar;
PROTECT(bar = allocMatrix(REALSXP, mrow, ncol));
/* linearity output */
for (i = 0; i < mrow; i++)
if (set_member(i + 1, aout->linset))
REAL(bar)[i] = 1.0;
else
REAL(bar)[i] = 0.0;
/* note conversion from zero-origin to one-origin indexing */
/* matrix output */
for (j = 1, k = mrow; j < ncol; j++)
for (i = 0; i < mrow; i++, k++) {
double ax = ddf_get_d(aout->matrix[i][j - 1]);
/* note our matrix has one more column than Fukuda's */
REAL(bar)[k] = ax;
}
int nresult = 1;
SEXP baz_adj = NULL;
if (LOGICAL(adjacency)[0]) {
ddf_SetFamilyPtr sout = ddf_CopyAdjacency(poly);
PROTECT(baz_adj = rrf_WriteSetFamily(sout));
ddf_FreeSetFamily(sout);
nresult++;
}
SEXP baz_inp_adj = NULL;
if (LOGICAL(inputadjacency)[0]) {
ddf_SetFamilyPtr sout = ddf_CopyInputAdjacency(poly);
PROTECT(baz_inp_adj = rrf_WriteSetFamily(sout));
ddf_FreeSetFamily(sout);
nresult++;
}
SEXP baz_inc = NULL;
if (LOGICAL(incidence)[0]) {
ddf_SetFamilyPtr sout = ddf_CopyIncidence(poly);
PROTECT(baz_inc = rrf_WriteSetFamily(sout));
ddf_FreeSetFamily(sout);
nresult++;
}
SEXP baz_inp_inc = NULL;
if (LOGICAL(inputincidence)[0]) {
ddf_SetFamilyPtr sout = ddf_CopyInputIncidence(poly);
PROTECT(baz_inp_inc = rrf_WriteSetFamily(sout));
ddf_FreeSetFamily(sout);
nresult++;
}
SEXP result, resultnames;
PROTECT(result = allocVector(VECSXP, nresult));
PROTECT(resultnames = allocVector(STRSXP, nresult));
SET_STRING_ELT(resultnames, 0, mkChar("output"));
SET_VECTOR_ELT(result, 0, bar);
int iresult = 1;
if (baz_adj) {
SET_STRING_ELT(resultnames, iresult, mkChar("adjacency"));
SET_VECTOR_ELT(result, iresult, baz_adj);
iresult++;
}
if (baz_inp_adj) {
SET_STRING_ELT(resultnames, iresult, mkChar("inputadjacency"));
SET_VECTOR_ELT(result, iresult, baz_inp_adj);
iresult++;
}
if (baz_inc) {
SET_STRING_ELT(resultnames, iresult, mkChar("incidence"));
SET_VECTOR_ELT(result, iresult, baz_inc);
iresult++;
}
if (baz_inp_inc) {
SET_STRING_ELT(resultnames, iresult, mkChar("inputincidence"));
SET_VECTOR_ELT(result, iresult, baz_inp_inc);
iresult++;
}
namesgets(result, resultnames);
if (aout->objective != ddf_LPnone)
error("Cannot happen! aout->objective != ddf_LPnone\n");
ddf_FreeMatrix(aout);
ddf_FreeMatrix(mf);
ddf_FreePolyhedra(poly);
ddf_clear(value);
ddf_free_global_constants();
UNPROTECT(2 + nresult);
PutRNGstate();
return result;
}
int compareValue(char *s, varInfo *v, int i)
{ Rval *q;
int ret;
if (v)
{
int type;
type = (int)(v->T.basicType);
if ((type != T_REAL) && (type != T_STRING))
{ if (isReal(s))
type = T_REAL;
else
type = T_STRING;
}
if (i) /* variable name with index */
{ if (i <= v->T.size+1)
{ if ((q=selectRval(v,i)) != NULL)
{ switch( type )
{ case T_STRING: default:
if (strcmp(s, q->v.s) != 0)
ret = 1;
else
ret = 2;
break;
case T_REAL:
{ char jstr[32];
sprintf(jstr,"%g",q->v.r);
/* compare strings instead of realString() using reals; more reliable */
if (strcmp(s,jstr) != 0)
ret = 1;
else
ret = 2;
}
break;
}
}
else
ret = 1;
}
else
ret = 3;
}
else /* variable without index */
{ q = v->R;
if (q)
{ switch( type )
{ case T_STRING: default:
if (strcmp(s, q->v.s) != 0)
ret = 1;
else
ret = 2;
break;
case T_REAL:
{ char jstr[32];
sprintf(jstr,"%g",q->v.r);
/* compare strings instead of realString() using reals; more reliable */
if (strcmp(s,jstr) != 0)
ret = 1;
else
ret = 2;
}
break;
}
}
else
ret = 1;
}
}
else
ret = 0;
return(ret);
}
std::shared_ptr<Operand> PredicateParser::createPrimitive(const std::string& fullExpression, size_t from, size_t to)
{
from = skipSpace(fullExpression, from, to);
while(to > from && std::isspace(fullExpression.at(to - 1)))
{
--to;
}
if(from >= to)
{
return nullptr;
}
char c = fullExpression.at(from);
switch(c)
{
case '"':
{
auto last = skipString(fullExpression, from + 1, to);
auto str = fullExpression.substr(from + 1, last - from - 1);
if(last == to)
{
throw std::logic_error(str + " not a string");
}
return std::make_shared<StringOperand>(str);
}
case '^':
case '.':
{
Compiler subCompiler;
auto subExpression = subCompiler.compile(fullExpression, from, to);
return std::make_shared<LocationOperand>(subExpression);
}
case '{':
case '[':
{
std::stack<char> unmatched;
unmatched.push(c);
auto last = skip2MatchParenthesis(unmatched, fullExpression, from + 1, to);
auto str = fullExpression.substr(from, last - from + 1);
if(last == to)
{
throw std::logic_error(str + " not a json");
}
json value = json::parse(str);
return std::make_shared<JsonOperand>(value);
}
case '/':
{
auto toPos = skip2(fullExpression, from + 1, '/', to);
auto regex = fullExpression.substr(from + 1, toPos - from - 1);
return std::make_shared<RegexOperand>(regex);
}
case '$':
{
auto variableName = fullExpression.substr(from + 1, to - from - 1);
return std::make_shared<VariableOperand>(variableName);
}
default:
if(isBool(fullExpression, from, to) && '0' != fullExpression.at(from) && '1' != fullExpression.at(from))
{
bool v = convert2Bool(fullExpression, from, to);
return std::make_shared<BoolOperand>(v);
}
else if(isInt(fullExpression, from, to))
{
int v = convert2Int(fullExpression, from, to);
return std::make_shared<IntOperand>(v);
}
else if(isReal(fullExpression, from, to))
{
double v = convert2Real(fullExpression, from, to);
return std::make_shared<RealOperand>(v);
}
else
{
throw std::logic_error(fullExpression.substr(from, to - from) + " can't be interpreted as an operand");
}
}
}
SEXP nlm(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP value, names, v, R_gradientSymbol, R_hessianSymbol;
double *x, *typsiz, fscale, gradtl, stepmx,
steptol, *xpls, *gpls, fpls, *a, *wrk, dlt;
int code, i, j, k, itnlim, method, iexp, omsg, msg,
n, ndigit, iagflg, iahflg, want_hessian, itncnt;
/* .Internal(
* nlm(function(x) f(x, ...), p, hessian, typsize, fscale,
* msg, ndigit, gradtol, stepmax, steptol, iterlim)
*/
function_info *state;
args = CDR(args);
PrintDefaults();
state = (function_info *) R_alloc(1, sizeof(function_info));
/* the function to be minimized */
v = CAR(args);
if (!isFunction(v))
error(_("attempt to minimize non-function"));
PROTECT(state->R_fcall = lang2(v, R_NilValue));
args = CDR(args);
/* `p' : inital parameter value */
n = 0;
x = fixparam(CAR(args), &n);
args = CDR(args);
/* `hessian' : H. required? */
want_hessian = asLogical(CAR(args));
if (want_hessian == NA_LOGICAL) want_hessian = 0;
args = CDR(args);
/* `typsize' : typical size of parameter elements */
typsiz = fixparam(CAR(args), &n);
args = CDR(args);
/* `fscale' : expected function size */
fscale = asReal(CAR(args));
if (ISNA(fscale)) error(_("invalid NA value in parameter"));
args = CDR(args);
/* `msg' (bit pattern) */
omsg = msg = asInteger(CAR(args));
if (msg == NA_INTEGER) error(_("invalid NA value in parameter"));
args = CDR(args);
ndigit = asInteger(CAR(args));
if (ndigit == NA_INTEGER) error(_("invalid NA value in parameter"));
args = CDR(args);
gradtl = asReal(CAR(args));
if (ISNA(gradtl)) error(_("invalid NA value in parameter"));
args = CDR(args);
stepmx = asReal(CAR(args));
if (ISNA(stepmx)) error(_("invalid NA value in parameter"));
args = CDR(args);
steptol = asReal(CAR(args));
if (ISNA(steptol)) error(_("invalid NA value in parameter"));
args = CDR(args);
/* `iterlim' (def. 100) */
itnlim = asInteger(CAR(args));
if (itnlim == NA_INTEGER) error(_("invalid NA value in parameter"));
state->R_env = rho;
/* force one evaluation to check for the gradient and hessian */
iagflg = 0; /* No analytic gradient */
iahflg = 0; /* No analytic hessian */
state->have_gradient = 0;
state->have_hessian = 0;
R_gradientSymbol = install("gradient");
R_hessianSymbol = install("hessian");
/* This vector is shared with all subsequent calls */
v = allocVector(REALSXP, n);
for (i = 0; i < n; i++) REAL(v)[i] = x[i];
SETCADR(state->R_fcall, v);
SET_NAMED(v, 2); // in case the functions try to alter it
value = eval(state->R_fcall, state->R_env);
v = getAttrib(value, R_gradientSymbol);
if (v != R_NilValue) {
if (LENGTH(v) == n && (isReal(v) || isInteger(v))) {
iagflg = 1;
state->have_gradient = 1;
v = getAttrib(value, R_hessianSymbol);
if (v != R_NilValue) {
if (LENGTH(v) == (n * n) && (isReal(v) || isInteger(v))) {
iahflg = 1;
state->have_hessian = 1;
} else {
warning(_("hessian supplied is of the wrong length or mode, so ignored"));
}
}
} else {
warning(_("gradient supplied is of the wrong length or mode, so ignored"));
}
}
if (((msg/4) % 2) && !iahflg) { /* skip check of analytic Hessian */
msg -= 4;
}
if (((msg/2) % 2) && !iagflg) { /* skip check of analytic gradient */
msg -= 2;
}
FT_init(n, FT_SIZE, state);
/* Plug in the call to the optimizer here */
method = 1; /* Line Search */
iexp = iahflg ? 0 : 1; /* Function calls are expensive */
dlt = 1.0;
xpls = (double*)R_alloc(n, sizeof(double));
gpls = (double*)R_alloc(n, sizeof(double));
a = (double*)R_alloc(n*n, sizeof(double));
wrk = (double*)R_alloc(8*n, sizeof(double));
/*
* Dennis + Schnabel Minimizer
*
* SUBROUTINE OPTIF9(NR,N,X,FCN,D1FCN,D2FCN,TYPSIZ,FSCALE,
* + METHOD,IEXP,MSG,NDIGIT,ITNLIM,IAGFLG,IAHFLG,IPR,
* + DLT,GRADTL,STEPMX,STEPTOL,
* + XPLS,FPLS,GPLS,ITRMCD,A,WRK)
*
*
* Note: I have figured out what msg does.
* It is actually a sum of bit flags as follows
* 1 = don't check/warn for 1-d problems
* 2 = don't check analytic gradients
* 4 = don't check analytic hessians
* 8 = don't print start and end info
* 16 = print at every iteration
* Using msg=9 is absolutely minimal
* I think we always check gradients and hessians
*/
optif9(n, n, x, (fcn_p) fcn, (fcn_p) Cd1fcn, (d2fcn_p) Cd2fcn,
state, typsiz, fscale, method, iexp, &msg, ndigit, itnlim,
iagflg, iahflg, dlt, gradtl, stepmx, steptol, xpls, &fpls,
gpls, &code, a, wrk, &itncnt);
if (msg < 0)
opterror(msg);
if (code != 0 && (omsg&8) == 0)
optcode(code);
if (want_hessian) {
PROTECT(value = allocVector(VECSXP, 6));
PROTECT(names = allocVector(STRSXP, 6));
fdhess(n, xpls, fpls, (fcn_p) fcn, state, a, n, &wrk[0], &wrk[n],
ndigit, typsiz);
for (i = 0; i < n; i++)
for (j = 0; j < i; j++)
a[i + j * n] = a[j + i * n];
}
else {
PROTECT(value = allocVector(VECSXP, 5));
PROTECT(names = allocVector(STRSXP, 5));
}
k = 0;
SET_STRING_ELT(names, k, mkChar("minimum"));
SET_VECTOR_ELT(value, k, ScalarReal(fpls));
k++;
SET_STRING_ELT(names, k, mkChar("estimate"));
SET_VECTOR_ELT(value, k, allocVector(REALSXP, n));
for (i = 0; i < n; i++)
REAL(VECTOR_ELT(value, k))[i] = xpls[i];
k++;
SET_STRING_ELT(names, k, mkChar("gradient"));
SET_VECTOR_ELT(value, k, allocVector(REALSXP, n));
for (i = 0; i < n; i++)
REAL(VECTOR_ELT(value, k))[i] = gpls[i];
k++;
if (want_hessian) {
SET_STRING_ELT(names, k, mkChar("hessian"));
SET_VECTOR_ELT(value, k, allocMatrix(REALSXP, n, n));
for (i = 0; i < n * n; i++)
REAL(VECTOR_ELT(value, k))[i] = a[i];
k++;
}
SET_STRING_ELT(names, k, mkChar("code"));
SET_VECTOR_ELT(value, k, allocVector(INTSXP, 1));
INTEGER(VECTOR_ELT(value, k))[0] = code;
k++;
/* added by Jim K Lindsey */
SET_STRING_ELT(names, k, mkChar("iterations"));
SET_VECTOR_ELT(value, k, allocVector(INTSXP, 1));
INTEGER(VECTOR_ELT(value, k))[0] = itncnt;
k++;
setAttrib(value, R_NamesSymbol, names);
UNPROTECT(3);
return value;
}
SEXP x_OP_y(SEXP x, SEXP y, SEXP dim, SEXP operator, SEXP xrows, SEXP xcols, SEXP yidxs, SEXP commute, SEXP naRm, SEXP hasNA, SEXP byRow) {
SEXP ans = NILSXP;
int narm, hasna, byrow, commute2;
int op;
R_xlen_t nrow, ncol, ny;
/* Argument 'x' and 'dim': */
assertArgMatrix(x, dim, (R_TYPE_INT | R_TYPE_REAL), "x");
nrow = asR_xlen_t(dim, 0);
ncol = asR_xlen_t(dim, 1);
/* Argument 'y': */
assertArgVector(y, (R_TYPE_INT | R_TYPE_REAL), "y");
ny = xlength(y);
/* Argument 'byRow': */
byrow = asLogicalNoNA(byRow, "byrow");
/* Argument 'commute2': */
commute2 = asLogicalNoNA(commute, "commute");
/* Argument 'naRm': */
narm = asLogicalNoNA(naRm, "na.rm");
/* Argument 'hasNA': */
hasna = asLogicalNoNA(hasNA, "hasNA");
/* Argument 'xrows', 'xcols' and 'yidxs': */
R_xlen_t nxrows, nxcols, nyidxs;
int xrowsType, xcolsType, yidxsType;
void *cxrows = validateIndices(xrows, nrow, 0, &nxrows, &xrowsType);
void *cxcols = validateIndices(xcols, ncol, 0, &nxcols, &xcolsType);
void *cyidxs = validateIndices(yidxs, ny, 1, &nyidxs, &yidxsType);
/* Argument 'operator': */
op = asInteger(operator);
if (op == 1) {
/* Addition */
if (isReal(x) || isReal(y)) {
PROTECT(ans = allocMatrix(REALSXP, nxrows, nxcols));
if (isReal(x) && isReal(y)) {
x_OP_y_Add_Real_Real[xrowsType][xcolsType][yidxsType](
REAL(x), nrow, ncol, REAL(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans));
} else if (isReal(x) && isInteger(y)) {
x_OP_y_Add_Real_Integer[xrowsType][xcolsType][yidxsType](
REAL(x), nrow, ncol, INTEGER(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans));
} else if (isInteger(x) && isReal(y)) {
x_OP_y_Add_Integer_Real[xrowsType][xcolsType][yidxsType](
INTEGER(x), nrow, ncol, REAL(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans));
}
UNPROTECT(1);
} else {
PROTECT(ans = allocMatrix(INTSXP, nxrows, nxcols));
x_OP_y_Add_Integer_Integer[xrowsType][xcolsType][yidxsType](
INTEGER(x), nrow, ncol, INTEGER(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, INTEGER(ans), xlength(ans));
UNPROTECT(1);
}
} if (op == 2) {
/* Subtraction */
if (isReal(x) || isReal(y)) {
PROTECT(ans = allocMatrix(REALSXP, nxrows, nxcols));
if (isReal(x) && isReal(y)) {
x_OP_y_Sub_Real_Real[xrowsType][xcolsType][yidxsType](
REAL(x), nrow, ncol, REAL(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans));
} else if (isReal(x) && isInteger(y)) {
x_OP_y_Sub_Real_Integer[xrowsType][xcolsType][yidxsType](
REAL(x), nrow, ncol, INTEGER(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans));
} else if (isInteger(x) && isReal(y)) {
x_OP_y_Sub_Integer_Real[xrowsType][xcolsType][yidxsType](
INTEGER(x), nrow, ncol, REAL(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans));
}
UNPROTECT(1);
} else {
PROTECT(ans = allocMatrix(INTSXP, nxrows, nxcols));
x_OP_y_Sub_Integer_Integer[xrowsType][xcolsType][yidxsType](
INTEGER(x), nrow, ncol, INTEGER(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, INTEGER(ans), xlength(ans));
UNPROTECT(1);
}
} else if (op == 3) {
/* Multiplication */
if (isReal(x) || isReal(y)) {
PROTECT(ans = allocMatrix(REALSXP, nxrows, nxcols));
if (isReal(x) && isReal(y)) {
x_OP_y_Mul_Real_Real[xrowsType][xcolsType][yidxsType](
REAL(x), nrow, ncol, REAL(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans));
} else if (isReal(x) && isInteger(y)) {
x_OP_y_Mul_Real_Integer[xrowsType][xcolsType][yidxsType](
REAL(x), nrow, ncol, INTEGER(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans));
} else if (isInteger(x) && isReal(y)) {
x_OP_y_Mul_Integer_Real[xrowsType][xcolsType][yidxsType](
INTEGER(x), nrow, ncol, REAL(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans));
}
UNPROTECT(1);
} else {
PROTECT(ans = allocMatrix(INTSXP, nxrows, nxcols));
x_OP_y_Mul_Integer_Integer[xrowsType][xcolsType][yidxsType](
INTEGER(x), nrow, ncol, INTEGER(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, INTEGER(ans), xlength(ans));
UNPROTECT(1);
}
} else if (op == 4) {
/* Division */
PROTECT(ans = allocMatrix(REALSXP, nxrows, nxcols));
if (isReal(x) && isReal(y)) {
x_OP_y_Div_Real_Real[xrowsType][xcolsType][yidxsType](
REAL(x), nrow, ncol, REAL(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans));
} else if (isReal(x) && isInteger(y)) {
x_OP_y_Div_Real_Integer[xrowsType][xcolsType][yidxsType](
REAL(x), nrow, ncol, INTEGER(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans));
} else if (isInteger(x) && isReal(y)) {
x_OP_y_Div_Integer_Real[xrowsType][xcolsType][yidxsType](
INTEGER(x), nrow, ncol, REAL(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans));
} else if (isInteger(x) && isInteger(y)) {
x_OP_y_Div_Integer_Integer[xrowsType][xcolsType][yidxsType](
INTEGER(x), nrow, ncol, INTEGER(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans));
}
UNPROTECT(1);
}
return(ans);
} /* x_OP_y() */
static PyObject *
Pygmpy_xmpz(PyObject *self, PyObject *args, PyObject *keywds)
{
PyxmpzObject *result = 0;
PyObject *n = 0;
long base = 0;
Py_ssize_t argc;
static char *kwlist[] = {"n", "base", NULL };
/* Optimize the most common use case */
argc = PyTuple_Size(args);
if (argc == 1) {
n = PyTuple_GetItem(args, 0);
#ifdef WITHMPFR
if (isReal(n) && !keywds) {
#else
if ((isRational(n) || PyFloat_Check(n)) && !keywds) {
#endif
result = Pyxmpz_From_Number(n);
if (!result && !PyErr_Occurred())
TYPE_ERROR("xmpz() requires numeric or string argument");
return (PyObject*)result;
}
}
if (!PyArg_ParseTupleAndKeywords(args, keywds, "O|l", kwlist,
&n, &base))
return NULL;
if ((base!=0) && ((base<2)||(base>62))) {
VALUE_ERROR("base for xmpz() must be 0 or in the "
"interval 2 ... 62");
return NULL;
}
if (PyStrOrUnicode_Check(n)) {
/* build-from-string (ascii or unicode) */
result = Pyxmpz_From_PyStr(n, base);
}
else {
if (argc==2 || (argc == 1 && keywds))
TYPE_ERROR("xmpz() with non-string argument needs exactly "
"1 argument");
else {
result = Pyxmpz_From_Number(n);
if (!result && !PyErr_Occurred())
TYPE_ERROR("xmpz() requires numeric or string argument");
}
}
return (PyObject*)result;
}
/* For many xmpz_functions, the doc-strings are in gmpy_mpz.c. */
static PyObject *
Pyxmpz_digits(PyObject *self, PyObject *args)
{
long base = 10;
PyObject *result;
PARSE_ONE_MPZ_OPT_CLONG(&base,
"digits() requires 'int' argument for base");
result = Pyxmpz_To_PyStr((PyxmpzObject*)self, base, 0);
Py_DECREF(self);
return result;
}
SEXP freadR(
// params passed to freadMain
SEXP inputArg,
SEXP sepArg,
SEXP decArg,
SEXP quoteArg,
SEXP headerArg,
SEXP nrowLimitArg,
SEXP skipArg,
SEXP NAstringsArg,
SEXP stripWhiteArg,
SEXP skipEmptyLinesArg,
SEXP fillArg,
SEXP showProgressArg,
SEXP nThreadArg,
SEXP verboseArg,
SEXP warnings2errorsArg,
// extras needed by callbacks from freadMain
SEXP selectArg,
SEXP dropArg,
SEXP colClassesArg,
SEXP integer64Arg,
SEXP encodingArg
) {
verbose = LOGICAL(verboseArg)[0];
warningsAreErrors = LOGICAL(warnings2errorsArg)[0];
freadMainArgs args;
protecti=0;
ncol = 0;
const char *ch, *ch2;
if (!isString(inputArg) || LENGTH(inputArg)!=1)
error("fread input must be a single character string: a filename or the data itself");
ch = ch2 = (const char *)CHAR(STRING_ELT(inputArg,0));
while (*ch2!='\n' && *ch2!='\0') ch2++;
args.input = (*ch2=='\n') ? ch : R_ExpandFileName(ch); // for convenience so user doesn't have to call path.expand()
ch = args.input;
while (*ch!='\0' && *ch!='\n') ch++;
if (*ch=='\n' || args.input[0]=='\0') {
if (verbose) DTPRINT("Input contains a \\n (or is \"\"). Taking this to be text input (not a filename)\n");
args.filename = NULL;
} else {
if (verbose) DTPRINT("Input contains no \\n. Taking this to be a filename to open\n");
args.filename = args.input;
args.input = NULL;
}
if (!isString(sepArg) || LENGTH(sepArg)!=1 || strlen(CHAR(STRING_ELT(sepArg,0)))>1)
error("CfreadR: sep must be 'auto' or a single character ('\\n' is an acceptable single character)");
args.sep = CHAR(STRING_ELT(sepArg,0))[0]; // '\0' when default "auto" was replaced by "" at R level
if (!(isString(decArg) && LENGTH(decArg)==1 && strlen(CHAR(STRING_ELT(decArg,0)))==1))
error("CfreadR: dec must be a single character such as '.' or ','");
args.dec = CHAR(STRING_ELT(decArg,0))[0];
if (!isString(quoteArg) || LENGTH(quoteArg)!=1 || strlen(CHAR(STRING_ELT(quoteArg,0))) > 1)
error("CfreadR: quote must be a single character or empty \"\"");
args.quote = CHAR(STRING_ELT(quoteArg,0))[0];
// header is the only boolean where NA is valid and means 'auto'.
// LOGICAL in R is signed 32 bits with NA_LOGICAL==INT_MIN, currently.
args.header = FALSE;
if (LOGICAL(headerArg)[0]==NA_LOGICAL) args.header = NA_BOOL8;
else if (LOGICAL(headerArg)[0]==TRUE) args.header = TRUE;
args.nrowLimit = INT64_MAX;
// checked at R level
if (isReal(nrowLimitArg)) {
if (R_FINITE(REAL(nrowLimitArg)[0]) && REAL(nrowLimitArg)[0]>=0.0) args.nrowLimit = (int64_t)(REAL(nrowLimitArg)[0]);
} else {
if (INTEGER(nrowLimitArg)[0]>=0) args.nrowLimit = (int64_t)INTEGER(nrowLimitArg)[0];
}
args.skipNrow=0;
args.skipString=NULL;
if (isString(skipArg)) {
args.skipString = CHAR(STRING_ELT(skipArg,0)); // LENGTH==1 was checked at R level
} else if (isReal(skipArg)) {
if (R_FINITE(REAL(skipArg)[0]) && REAL(skipArg)[0]>0.0) args.skipNrow = (uint64_t)REAL(skipArg)[0];
} else if (isInteger(skipArg)) {
if (INTEGER(skipArg)[0]>0) args.skipNrow = (uint64_t)INTEGER(skipArg)[0];
} else error("skip must be a single positive numeric (integer or double), or a string to search for");
if (!isNull(NAstringsArg) && !isString(NAstringsArg))
error("'na.strings' is type '%s'. Must be either NULL or a character vector.", type2char(TYPEOF(NAstringsArg)));
int nnas = length(NAstringsArg);
if (nnas>100) // very conservative limit
error("length(na.strings)==%d. This is too many to allocate pointers for on stack", nnas);
const char **NAstrings = alloca((nnas + 1) * sizeof(char*));
for (int i=0; i<nnas; i++)
NAstrings[i] = CHAR(STRING_ELT(NAstringsArg,i));
NAstrings[nnas] = NULL;
args.NAstrings = NAstrings;
// here we use _Bool and rely on fread at R level to check these do not contain NA_LOGICAL
args.stripWhite = LOGICAL(stripWhiteArg)[0];
args.skipEmptyLines = LOGICAL(skipEmptyLinesArg)[0];
args.fill = LOGICAL(fillArg)[0];
args.showProgress = LOGICAL(showProgressArg)[0];
if (INTEGER(nThreadArg)[0]<1) error("nThread(%d)<1", INTEGER(nThreadArg)[0]);
args.nth = (uint32_t)INTEGER(nThreadArg)[0];
args.verbose = verbose;
args.warningsAreErrors = warningsAreErrors;
// === extras used for callbacks ===
if (!isString(integer64Arg) || LENGTH(integer64Arg)!=1) error("'integer64' must be a single character string");
const char *tt = CHAR(STRING_ELT(integer64Arg,0));
if (strcmp(tt, "integer64")==0) {
readInt64As = CT_INT64;
} else if (strcmp(tt, "character")==0) {
readInt64As = CT_STRING;
} else if (strcmp(tt,"double")==0 || strcmp(tt,"numeric")==0) {
readInt64As = CT_FLOAT64;
} else STOP("Invalid value integer64='%s'. Must be 'integer64', 'character', 'double' or 'numeric'", tt);
colClassesSxp = colClassesArg; // checked inside userOverride where it is used.
if (!isNull(selectArg) && !isNull(dropArg)) STOP("Use either select= or drop= but not both.");
selectSxp = selectArg;
dropSxp = dropArg;
// Encoding, #563: Borrowed from do_setencoding from base R
// https://github.com/wch/r-source/blob/ca5348f0b5e3f3c2b24851d7aff02de5217465eb/src/main/util.c#L1115
// Check for mkCharLenCE function to locate as to where where this is implemented.
tt = CHAR(STRING_ELT(encodingArg, 0));
if (strcmp(tt, "unknown")==0) ienc = CE_NATIVE;
else if (strcmp(tt, "Latin-1")==0) ienc = CE_LATIN1;
else if (strcmp(tt, "UTF-8")==0) ienc = CE_UTF8;
else STOP("encoding='%s' invalid. Must be 'unknown', 'Latin-1' or 'UTF-8'", tt);
// === end extras ===
DT = R_NilValue; // created by callback
freadMain(args);
UNPROTECT(protecti);
return DT;
}
extern void DEBUG_LoadSymbols( char *name )
{
bfd* abfd;
char **matching;
bfd_init();
abfd = bfd_openr(name, "default");
if (abfd == NULL) {
barf("can't open executable %s to get symbol table", name);
}
if (!bfd_check_format_matches (abfd, bfd_object, &matching)) {
barf("mismatch");
}
{
long storage_needed;
asymbol **symbol_table;
long number_of_symbols;
long num_real_syms = 0;
long i;
storage_needed = bfd_get_symtab_upper_bound (abfd);
if (storage_needed < 0) {
barf("can't read symbol table");
}
#if 0
if (storage_needed == 0) {
debugBelch("no storage needed");
}
#endif
symbol_table = (asymbol **) stgMallocBytes(storage_needed,"DEBUG_LoadSymbols");
number_of_symbols = bfd_canonicalize_symtab (abfd, symbol_table);
if (number_of_symbols < 0) {
barf("can't canonicalise symbol table");
}
for( i = 0; i != number_of_symbols; ++i ) {
symbol_info info;
bfd_get_symbol_info(abfd,symbol_table[i],&info);
/*debugBelch("\t%c\t0x%x \t%s\n",info.type,(nat)info.value,info.name); */
if (isReal(info.type, info.name)) {
num_real_syms += 1;
}
}
IF_DEBUG(interpreter,
debugBelch("Loaded %ld symbols. Of which %ld are real symbols\n",
number_of_symbols, num_real_syms)
);
reset_table( num_real_syms );
for( i = 0; i != number_of_symbols; ++i ) {
symbol_info info;
bfd_get_symbol_info(abfd,symbol_table[i],&info);
if (isReal(info.type, info.name)) {
insert( info.value, info.name );
}
}
stgFree(symbol_table);
}
prepare_table();
}
SEXP mc_select_children(SEXP sTimeout, SEXP sWhich)
{
int maxfd = 0, sr, zombies = 0;
unsigned int wlen = 0, wcount = 0;
SEXP res;
int *res_i, *which = 0;
child_info_t *ci = children;
fd_set fs;
struct timeval tv = { 0, 0 }, *tvp = &tv;
if (isReal(sTimeout) && LENGTH(sTimeout) == 1) {
double tov = asReal(sTimeout);
if (tov < 0.0) tvp = 0; /* Note: I'm not sure we really should allow this .. */
else {
tv.tv_sec = (int) tov;
tv.tv_usec = (int) ((tov - ((double) tv.tv_sec)) * 1000000.0);
}
}
if (TYPEOF(sWhich) == INTSXP && LENGTH(sWhich)) {
which = INTEGER(sWhich);
wlen = LENGTH(sWhich);
}
clean_zombies();
FD_ZERO(&fs);
while (ci && ci->pid) {
if (ci->pfd == -1) zombies++;
if (ci->pfd > maxfd) maxfd = ci->pfd;
if (ci->pfd > 0) {
if (which) { /* check for the FD only if it's on the list */
unsigned int k = 0;
while (k < wlen)
if (which[k++] == ci->pid) {
FD_SET(ci->pfd, &fs);
wcount++;
break;
}
} else FD_SET(ci->pfd, &fs);
}
ci = ci -> next;
}
/* if there are any closed children, remove them - don't bother otherwise */
if (zombies) rm_closed();
#ifdef MC_DEBUG
Dprintf("select_children: maxfd=%d, wlen=%d, wcount=%d, zombies=%d, timeout=%d:%d\n", maxfd, wlen, wcount, zombies, (int)tv.tv_sec, (int)tv.tv_usec);
#endif
if (maxfd == 0 || (wlen && !wcount))
return R_NilValue; /* NULL signifies no children to tend to */
sr = select(maxfd + 1, &fs, 0, 0, tvp);
#ifdef MC_DEBUG
Dprintf(" sr = %d\n", sr);
#endif
if (sr < 0) {
/* we can land here when a child terminated due to arriving SIGCHLD.
For simplicity we treat this as timeout. The alernative would be to
go back to select, but potentially this could lead to a much longer
total timeout */
if (errno == EINTR)
return ScalarLogical(TRUE);
warning(_("error '%s' in select"), strerror(errno));
return ScalarLogical(FALSE); /* FALSE on select error */
}
if (sr < 1) return ScalarLogical(1); /* TRUE on timeout */
ci = children;
maxfd = 0;
while (ci && ci->pid) { /* pass 1 - count the FDs (in theory not
necessary since that's what select
should have returned) */
if (ci->pfd > 0 && FD_ISSET(ci->pfd, &fs)) maxfd++;
ci = ci -> next;
}
ci = children;
#ifdef MC_DEBUG
Dprintf(" - read select %d children: ", maxfd);
#endif
res = allocVector(INTSXP, maxfd);
res_i = INTEGER(res);
while (ci && ci->pid) { /* pass 2 - fill the array */
if (ci->pfd > 0 && FD_ISSET(ci->pfd, &fs)) (res_i++)[0] = ci->pid;
#ifdef MC_DEBUG
if (ci->pfd > 0 && FD_ISSET(ci->pfd, &fs)) Dprintf("%d ", ci->pid);
#endif
ci = ci -> next;
}
#ifdef MC_DEBUG
Dprintf("\n");
#endif
return res;
}
SEXP bmerge(SEXP iArg, SEXP xArg, SEXP icolsArg, SEXP xcolsArg, SEXP isorted, SEXP xoArg, SEXP rollarg, SEXP rollendsArg, SEXP nomatchArg, SEXP multArg, SEXP opArg, SEXP nqgrpArg, SEXP nqmaxgrpArg) {
int xN, iN, protecti=0;
ctr=0; // needed for non-equi join case
SEXP retFirstArg, retLengthArg, retIndexArg, allLen1Arg, allGrp1Arg;
retFirstArg = retLengthArg = retIndexArg = R_NilValue; // suppress gcc msg
// iArg, xArg, icolsArg and xcolsArg
i = iArg; x = xArg; // set globals so bmerge_r can see them.
if (!isInteger(icolsArg)) error("Internal error: icols is not integer vector"); // # nocov
if (!isInteger(xcolsArg)) error("Internal error: xcols is not integer vector"); // # nocov
if (LENGTH(icolsArg) > LENGTH(xcolsArg)) error("Internal error: length(icols) [%d] > length(xcols) [%d]", LENGTH(icolsArg), LENGTH(xcolsArg)); // # nocov
icols = INTEGER(icolsArg);
xcols = INTEGER(xcolsArg);
xN = LENGTH(VECTOR_ELT(x,0));
iN = ilen = anslen = LENGTH(VECTOR_ELT(i,0));
ncol = LENGTH(icolsArg); // there may be more sorted columns in x than involved in the join
for(int col=0; col<ncol; col++) {
if (icols[col]==NA_INTEGER) error("Internal error. icols[%d] is NA", col); // # nocov
if (xcols[col]==NA_INTEGER) error("Internal error. xcols[%d] is NA", col); // # nocov
if (icols[col]>LENGTH(i) || icols[col]<1) error("icols[%d]=%d outside range [1,length(i)=%d]", col, icols[col], LENGTH(i));
if (xcols[col]>LENGTH(x) || xcols[col]<1) error("xcols[%d]=%d outside range [1,length(x)=%d]", col, xcols[col], LENGTH(x));
int it = TYPEOF(VECTOR_ELT(i, icols[col]-1));
int xt = TYPEOF(VECTOR_ELT(x, xcols[col]-1));
if (it != xt) error("typeof x.%s (%s) != typeof i.%s (%s)", CHAR(STRING_ELT(getAttrib(x,R_NamesSymbol),xcols[col]-1)), type2char(xt), CHAR(STRING_ELT(getAttrib(i,R_NamesSymbol),icols[col]-1)), type2char(it));
}
// raise(SIGINT);
// rollArg, rollendsArg
roll = 0.0; rollToNearest = FALSE;
if (isString(rollarg)) {
if (strcmp(CHAR(STRING_ELT(rollarg,0)),"nearest") != 0) error("roll is character but not 'nearest'");
roll=1.0; rollToNearest=TRUE; // the 1.0 here is just any non-0.0, so roll!=0.0 can be used later
} else {
if (!isReal(rollarg)) error("Internal error: roll is not character or double"); // # nocov
roll = REAL(rollarg)[0]; // more common case (rolling forwards or backwards) or no roll when 0.0
}
rollabs = fabs(roll);
if (!isLogical(rollendsArg) || LENGTH(rollendsArg) != 2)
error("rollends must be a length 2 logical vector");
rollends = LOGICAL(rollendsArg);
if (rollToNearest && TYPEOF(VECTOR_ELT(i, icols[ncol-1]-1))==STRSXP)
error("roll='nearest' can't be applied to a character column, yet.");
// nomatch arg
nomatch = INTEGER(nomatchArg)[0];
// mult arg
if (!strcmp(CHAR(STRING_ELT(multArg, 0)), "all")) mult = ALL;
else if (!strcmp(CHAR(STRING_ELT(multArg, 0)), "first")) mult = FIRST;
else if (!strcmp(CHAR(STRING_ELT(multArg, 0)), "last")) mult = LAST;
else error("Internal error: invalid value for 'mult'. please report to data.table issue tracker"); // # nocov
// opArg
if (!isInteger(opArg) || length(opArg) != ncol)
error("Internal error: opArg is not an integer vector of length equal to length(on)"); // # nocov
op = INTEGER(opArg);
if (!isInteger(nqgrpArg))
error("Internal error: nqgrpArg must be an integer vector"); // # nocov
nqgrp = nqgrpArg; // set global for bmerge_r
scols = (!length(nqgrpArg)) ? 0 : -1; // starting col index, -1 is external group column for non-equi join case
// nqmaxgrpArg
if (!isInteger(nqmaxgrpArg) || length(nqmaxgrpArg) != 1 || INTEGER(nqmaxgrpArg)[0] <= 0)
error("Intrnal error: nqmaxgrpArg is not a positive length-1 integer vector"); // # nocov
nqmaxgrp = INTEGER(nqmaxgrpArg)[0];
if (nqmaxgrp>1 && mult == ALL) {
// non-equi case with mult=ALL, may need reallocation
anslen = 1.1 * ((iN > 1000) ? iN : 1000);
retFirst = Calloc(anslen, int); // anslen is set above
retLength = Calloc(anslen, int);
retIndex = Calloc(anslen, int);
if (retFirst==NULL || retLength==NULL || retIndex==NULL)
error("Internal error in allocating memory for non-equi join"); // # nocov
// initialise retIndex here directly, as next loop is meant for both equi and non-equi joins
for (int j=0; j<anslen; j++) retIndex[j] = j+1;
} else { // equi joins (or) non-equi join but no multiple matches
