SEXP mfopt(SEXP fnstr, SEXP grstr, SEXP rho) {
SEXP N, PAR, DX, EPS, MAXFUN, W, IW, ICONTR, GRAD, GRSTEP ;
fn = fnstr ;
gr = grstr ;
environment = rho ;
PROTECT(N = findVarInFrame(rho, install(".n"))) ;
PROTECT(PAR = findVarInFrame(rho, install(".par"))) ;
PROTECT(DX = findVarInFrame(rho, install(".stepmax"))) ;
PROTECT(EPS = findVarInFrame(rho, install(".eps"))) ;
PROTECT(MAXFUN= findVarInFrame(rho, install(".maxfun"))) ;
PROTECT(W = findVarInFrame(rho, install(".w"))) ;
PROTECT(IW = findVarInFrame(rho, install(".iw"))) ;
PROTECT(ICONTR= findVarInFrame(rho, install(".icontr"))) ;
PROTECT(GRAD = findVarInFrame(rho, install(".grad"))) ;
PROTECT(GRSTEP= findVarInFrame(rho, install(".grstep"))) ;
// Call the FORTRAN routine 'ucminf'
F77_CALL(ucminf)(INTEGER(N),REAL(PAR), REAL(DX), REAL(EPS), INTEGER(MAXFUN),
REAL(W), INTEGER(IW), INTEGER(ICONTR),
INTEGER(GRAD),REAL(GRSTEP)) ;
UNPROTECT(10) ;
return R_NilValue;
}
/*
** The first routine saves away the parameters, the location
** of the evaluation frame and the 2 expressions to be computed within it,
** and ferrets away the memory location of the 4 "callback" objects.
*/
SEXP init_rpcallback(SEXP rhox, SEXP ny, SEXP nr,
SEXP expr1x, SEXP expr2x)
{
SEXP stemp;
rho = rhox;
ysave = asInteger(ny );
rsave = asInteger(nr);
expr1 = expr1x;
expr2 = expr2x;
stemp = findVarInFrame(rho, install("yback"));
if(!stemp) error("yback not found");
ydata = REAL(stemp);
stemp = findVarInFrame(rho, install("wback"));
if(!stemp) error("wback not found");
wdata = REAL(stemp);
stemp = findVarInFrame(rho, install("xback"));
if(!stemp) error("xback not found");
xdata = REAL(stemp);
stemp = findVarInFrame(rho, install("nback"));
if(!stemp) error("nback not found");
ndata = INTEGER(stemp);
return(R_NilValue);
}
SEXP port_nlminb(SEXP fn, SEXP gr, SEXP hs, SEXP rho,
SEXP lowerb, SEXP upperb, SEXP d, SEXP iv, SEXP v)
{
int i, n = LENGTH(d);
SEXP xpt;
double *b = (double *) NULL, *g = (double *) NULL,
*h = (double *) NULL, fx = R_PosInf;
if (isNull(rho)) {
error(_("use of NULL environment is defunct"));
rho = R_BaseEnv;
} else
if (!isEnvironment(rho))
error(_("'rho' must be an environment"));
if (!isReal(d) || n < 1)
error(_("'d' must be a nonempty numeric vector"));
if (hs != R_NilValue && gr == R_NilValue)
error(_("When Hessian defined must also have gradient defined"));
if (R_NilValue == (xpt = findVarInFrame(rho, install(".par"))) ||
!isReal(xpt) || LENGTH(xpt) != n)
error(_("environment 'rho' must contain a numeric vector '.par' of length %d"),
n);
/* We are going to alter .par, so must duplicate it */
defineVar(install(".par"), duplicate(xpt), rho);
PROTECT(xpt = findVarInFrame(rho, install(".par")));
if ((LENGTH(lowerb) == n) && (LENGTH(upperb) == n)) {
if (isReal(lowerb) && isReal(upperb)) {
double *rl=REAL(lowerb), *ru=REAL(upperb);
b = Calloc(2*n, double);
for (i = 0; i < n; i++) {
b[2*i] = rl[i];
b[2*i + 1] = ru[i];
}
} else error(_("'lower' and 'upper' must be numeric vectors"));
/**
* Calculate the sum of squared errors term for spatial regression
* using an environment to hold data
*
* @param env pointer to an SEXP environment
* @param coef current value of coefficient being optimzed
*
* @return double, value of SSE for current coef
*
*/
SEXP R_ml_sse_env(SEXP env, SEXP coef) {
SEXP res;
// SEXP y, x, wy, WX;
int i, k, n, p, np;
double tol=1e-7, cyl, cxlqyl, sse;
char *trans = "T";
double one = 1.0, zero = 0.0;
double m_lambda = - NUMERIC_POINTER(coef)[0];
int pc=0, first_time;
OPT_ERROR_SSE *pt;
first_time = LOGICAL_POINTER(findVarInFrame(env, install("first_time")))[0];
if (first_time) {
opt_error_set(env);
}
n = INTEGER_POINTER(findVarInFrame(env, install("n")))[0];
p = INTEGER_POINTER(findVarInFrame(env, install("p")))[0];
np = n*p;
pt = (OPT_ERROR_SSE *) R_ExternalPtrAddr(findVarInFrame(env,
install("ptr")));
for (i=0; i<n; i++) pt->yl[i] = pt->y[i];
for (i=0; i<np; i++) pt->xlq[i] = pt->x[i];
F77_CALL(daxpy)(&n, &m_lambda, pt->wy1, &c__1, pt->yl, &c__1);
F77_CALL(daxpy)(&np, &m_lambda, pt->wx1, &c__1, pt->xlq, &c__1);
F77_CALL(dqrdc2)(pt->xlq, &n, &n, &p, &tol, &k, pt->qraux, pt->jpvt,
pt->work);
if (p != k) warning("Q looses full rank");
/* k = 0;
F77_CALL(dqrdc)(pt->xlq, &n, &n, &p, pt->qraux, pt->jpvt, pt->work, &k);*/
for (i=0; i<n*k; i++) pt->qy[i] = 0.0;
for (i=0; i<k; i++) pt->qy[(i +(n*i))] = 1.0;
F77_CALL(dqrqy)(pt->xlq, &n, &k, pt->qraux, pt->qy, &k, pt->qy);
F77_CALL(dgemv)(trans, &n, &k, &one, pt->qy, &n, pt->yl, &c__1, &zero,
pt->xlqyl, &c__1);
cyl = F77_CALL(ddot)(&n, pt->yl, &c__1, pt->yl, &c__1);
cxlqyl = F77_CALL(ddot)(&k, pt->xlqyl, &c__1, pt->xlqyl, &c__1);
sse = cyl - cxlqyl;
PROTECT(res=NEW_NUMERIC(1)); pc++;
NUMERIC_POINTER(res)[0] = sse;
UNPROTECT(pc);
return(res);
}
SEXP oc_resolve(const char *ref) {
SEXP val;
if (!oc_env) return R_NilValue;
val = findVarInFrame(oc_env, install(ref));
if (val == R_UnboundValue) val = R_NilValue;
return val;
}
GEOSContextHandle_t getContextHandle(SEXP env) {
SEXP ptr = findVarInFrame(env, install("GEOSptr"));
GEOSContextHandle_t r = R_ExternalPtrAddr(ptr);
return(r);
}
SEXP InstanceObjectTable::get(const char * name, Rboolean* canCache) const {
SEXP ans = R_UnboundValue;
checkInstance();
if (canCache) *canCache = TRUE;
if (_internal) {
if (!qstrcmp(name, "this"))
ans = _instance->internalSexp(R_EmptyEnv);
else if (!qstrcmp(name, "super"))
ans = superClosure();
else ans = findVarInFrame(fieldEnv(), install(name));
if (ans == R_UnboundValue)
ans = enumValue(name);
}
if (ans == R_UnboundValue) {
Property *prop = _instance->klass()->property(name);
if (prop) { // FIXME: throw error if not readable?
if (prop->isReadable())
ans = prop->read(_instance->sexp());
delete prop;
}
}
if (ans == R_UnboundValue && methodExists(name))
ans = methodClosure(name); // make a wrapper for method
return ans;
}
void cfunc(int *n, double x[], double value[]) {
SEXP PAR ;
int i ;
PROTECT(PAR = findVarInFrame(environment, install(".x"))) ;
for (i = 0; i < *n; i++) REAL(PAR)[i] = x[i] ;
value[0] = asReal(eval(fn, environment)) ;
UNPROTECT(1) ;
}
SEXP R_ml1_sse_env(SEXP env, SEXP lambda, SEXP beta) {
SEXP res;
int i, n, p, np;
double sse;
char *trans = "N";
double one = 1.0, zero = 0.0, m_one = -1.0;
double m_lambda = - NUMERIC_POINTER(lambda)[0];
int pc=0, first_time;
HESS_ERROR_SSE *pt;
first_time = LOGICAL_POINTER(findVarInFrame(env, install("first_time")))[0];
if (first_time) {
hess_error_set(env);
}
n = INTEGER_POINTER(findVarInFrame(env, install("n")))[0];
p = INTEGER_POINTER(findVarInFrame(env, install("p")))[0];
np = n*p;
pt = (HESS_ERROR_SSE *) R_ExternalPtrAddr(findVarInFrame(env,
install("ptr")));
for (i=0; i<n; i++) pt->yl[i] = pt->y[i];
for (i=0; i<np; i++) pt->xl[i] = pt->x[i];
for (i=0; i<p; i++) pt->beta1[i] = NUMERIC_POINTER(beta)[i];
F77_CALL(daxpy)(&n, &m_lambda, pt->wy1, &c__1, pt->yl, &c__1);
F77_CALL(daxpy)(&np, &m_lambda, pt->wx1, &c__1, pt->xl, &c__1);
F77_CALL(dgemv)(trans, &n, &p, &one, pt->xl, &n, pt->beta1, &c__1, &zero,
pt->xlb, &c__1);
F77_CALL(daxpy)(&n, &m_one, pt->xlb, &c__1, pt->yl, &c__1);
sse = F77_CALL(ddot)(&n, pt->yl, &c__1, pt->yl, &c__1);
PROTECT(res=NEW_NUMERIC(1)); pc++;
NUMERIC_POINTER(res)[0] = sse;
UNPROTECT(pc);
return(res);
}
DL_FUNC R_GetCCallable(const char *package, const char *name)
{
SEXP penv = get_package_CEntry_table(package);
SEXP eptr = findVarInFrame(penv, install(name));
if (eptr == R_UnboundValue)
error(_("function '%s' not provided by package '%s'"), name, package);
else if (TYPEOF(eptr) != EXTPTRSXP)
error(_("table entry must be an external pointer"));
return R_ExternalPtrAddrFn(eptr);
}
void cgrad(int *n, double x[], double grval[]) {
SEXP PAR, OUT ;
int i ;
PROTECT(OUT = allocVector(REALSXP, *n)) ;
PROTECT(PAR = findVarInFrame(environment, install(".x"))) ;
for (i = 0; i < *n; i++) REAL(PAR)[i] = x[i] ;
OUT = eval(gr, environment) ;
for (i = 0; i < *n; i++) grval[i] = REAL(OUT)[i];
UNPROTECT(2) ;
}
SEXP rgeos_finish(SEXP env) {
GEOSContextHandle_t r = getContextHandle(env);
finishGEOS_r(r);
SEXP sxpHandle = findVarInFrame(env, install("GEOSptr"));
rgeos_finish_handle(sxpHandle);
return(R_NilValue);
}
bool
RClass::hasMethod(const char *name, Method::Qualifiers qualifiers) const {
bool found = parent()->hasMethod(name, qualifiers | Method::NotPrivate);
if (!found) {
SEXP fun = findVarInFrame(methodEnv(), install(name));
if (fun != R_UnboundValue && TYPEOF(fun) == CLOSXP)
found = (RMethod(this, name, fun).qualifiers() & qualifiers) ==
qualifiers;
}
return found;
}
Method *RClass::findMethod(const MethodCall &call) const {
const char * methodName = call.method()->name();
SEXP fun = findVarInFrame(methodEnv(), install(methodName));
Method *meth = NULL;
if (fun != R_UnboundValue && TYPEOF(fun) == CLOSXP &&
(!call.super() ||
(RMethod(this, methodName, fun).qualifiers() & Method::Private) == 0))
meth = new RMethod(this, methodName, fun, call.types());
else meth = parent()->findMethod(call);
return meth;
}
void hess_lag_set(SEXP env) {
HESS_LAG_SSE *pt;
SEXP y, x, wy;
int i, n, p, np;
n = INTEGER_POINTER(findVarInFrame(env, install("n")))[0];
p = INTEGER_POINTER(findVarInFrame(env, install("m")))[0];
np = n*p;
pt = (HESS_LAG_SSE *) R_ExternalPtrAddr(findVarInFrame(env,
install("ptr")));
if (pt->set) error("hess_lag_set: function called out of order");
y = findVarInFrame(env, install("y"));
x = findVarInFrame(env, install("x"));
wy = findVarInFrame(env, install("wy"));
pt->y = Calloc(n, double);
pt->x = Calloc(np, double);
pt->yl = Calloc(n, double);
pt->wy1 = Calloc(n, double);
pt->beta1 = Calloc(p, double);
pt->xb = Calloc(n, double);
for (i=0; i<n; i++) {
pt->y[i] = NUMERIC_POINTER(y)[i];
pt->wy1[i] = NUMERIC_POINTER(wy)[i];
}
for (i=0; i<np; i++) pt->x[i] = NUMERIC_POINTER(x)[i];
pt->set = TRUE;
return;
}
QList<Method *> RClass::methods(Method::Qualifiers qualifiers) const {
SEXP _env = methodEnv();
SEXP names = R_lsInternal(_env, (Rboolean)false);
QList<Method *> meths;
for (int i = 0; i < length(names); i++) {
const char *name = CHAR(STRING_ELT(names, i));
SEXP fun = findVarInFrame(_env, install(name));
if ((RMethod(this, name, fun).qualifiers() & qualifiers) == qualifiers)
meths << new RMethod(this, name, fun);
}
meths.append(parent()->methods(qualifiers | Method::NotPrivate));
return meths;
}
Property *RClass::property(const char *name) const {
Property *prop;
SEXP rprop = findVarInFrame(properties(), install(name));
if (rprop != R_UnboundValue) {
SEXP rtype = VECTOR_ELT(rprop, R_PROP_TYPE);
SmokeType type;
if (rtype == R_NilValue)
type = SmokeType(smokeBase()->smoke(), (Smoke::Index)0);
else type = SmokeType(smokeBase()->smoke(), CHAR(asChar(rtype)));
prop = new RProperty(name, type, VECTOR_ELT(rprop, R_PROP_READER),
VECTOR_ELT(rprop, R_PROP_WRITER));
}
else prop = parent()->property(name);
return prop;
}
static SEXP get_package_CEntry_table(const char *package)
{
SEXP penv, pname;
if (CEntryTable == NULL) {
CEntryTable = R_NewHashedEnv(R_NilValue, ScalarInteger(0));
R_PreserveObject(CEntryTable);
}
pname = install(package);
penv = findVarInFrame(CEntryTable, pname);
if (penv == R_UnboundValue) {
penv = R_NewHashedEnv(R_NilValue, ScalarInteger(0));
defineVar(pname, penv, CEntryTable);
}
return penv;
}
/* Return NULL on failure */
SEXP
SexpEnvironment_getvalue(const SEXP envir, const char* name) {
if (! RINTERF_ISREADY()) {
printf("R is not ready.\n");
return NULL;
}
RStatus ^= RINTERF_IDLE;
SEXP sexp, symbol;
symbol = Rf_install(name);
PROTECT(sexp = findVarInFrame(envir, symbol));
//FIXME: protect/unprotect from garbage collection (for now protect only)
R_PreserveObject(sexp);
UNPROTECT(1);
RStatus ^= RINTERF_IDLE;
return sexp;
}
int
SexpEnvironment_delvalue(const SEXP envir, const char* name) {
if (! RINTERF_ISREADY()) {
printf("R is not ready.\n");
return -1;
}
RStatus ^= RINTERF_IDLE;
if (envir == R_BaseNamespace) {
printf("Variables in the R base namespace cannot be changed.\n");
RStatus ^= RINTERF_IDLE;
return -1;
} else if (envir == R_BaseEnv) {
printf("Variables in the R base environment cannot be changed.\n");
RStatus ^= RINTERF_IDLE;
return -1;
} else if (envir == R_EmptyEnv) {
printf("Nothing can be changed from the empty environment.\n");
RStatus ^= RINTERF_IDLE;
return -1;
} else if (R_EnvironmentIsLocked(envir)) {
printf("Variables in a locked environment cannot be changed.\n");
RStatus ^= RINTERF_IDLE;
return -1;
}
SEXP sexp, symbol;
symbol = Rf_install(name);
PROTECT(sexp = findVarInFrame(envir, symbol));
if (sexp == R_UnboundValue) {
printf("'%s' not found.\n", name);
UNPROTECT(1);
RStatus ^= RINTERF_IDLE;
return -1;
}
SEXP res_rm = librinterface_remove(symbol, envir, R_BaseEnv);
if (! res_rm) {
printf("Could not remove the variable '%s' from environment.", name);
UNPROTECT(1);
RStatus ^= RINTERF_IDLE;
return -1;
}
UNPROTECT(1);
RStatus ^= RINTERF_IDLE;
return 0;
}
pGEDevDesc GEcurrentDevice(void)
{
/* If there are no active devices
* check the options for a "default device".
* If there is one, start it up. */
if (NoDevices()) {
SEXP defdev = GetOption1(install("device"));
if (isString(defdev) && length(defdev) > 0) {
SEXP devName = install(CHAR(STRING_ELT(defdev, 0)));
/* Not clear where this should be evaluated, since
grDevices need not be in the search path.
So we look for it first on the global search path.
*/
defdev = findVar(devName, R_GlobalEnv);
if(defdev != R_UnboundValue) {
PROTECT(defdev = lang1(devName));
eval(defdev, R_GlobalEnv);
UNPROTECT(1);
} else {
/* Not globally visible:
try grDevices namespace if loaded.
The option is unlikely to be set if it is not loaded,
as the default setting is in grDevices:::.onLoad.
*/
SEXP ns = findVarInFrame(R_NamespaceRegistry,
install("grDevices"));
if(ns != R_UnboundValue &&
findVar(devName, ns) != R_UnboundValue) {
PROTECT(defdev = lang1(devName));
eval(defdev, ns);
UNPROTECT(1);
} else
error(_("no active or default device"));
}
} else if(TYPEOF(defdev) == CLOSXP) {
PROTECT(defdev = lang1(defdev));
eval(defdev, R_GlobalEnv);
UNPROTECT(1);
} else
error(_("no active or default device"));
}
return R_Devices[R_CurrentDevice];
}
void opt_error_set(SEXP env) {
OPT_ERROR_SSE *pt;
SEXP y, x, wy, WX;
int i, n, p, np;
n = INTEGER_POINTER(findVarInFrame(env, install("n")))[0];
p = INTEGER_POINTER(findVarInFrame(env, install("p")))[0];
np = n*p;
pt = (OPT_ERROR_SSE *) R_ExternalPtrAddr(findVarInFrame(env,
install("ptr")));
if (pt->set) error("opt_error_set: function called out of order");
y = findVarInFrame(env, install("y"));
x = findVarInFrame(env, install("x"));
wy = findVarInFrame(env, install("wy"));
WX = findVarInFrame(env, install("WX"));
pt->y = Calloc(n, double);
pt->x = Calloc(np, double);
pt->yl = Calloc(n, double);
pt->wy1 = Calloc(n, double);
pt->xlq = Calloc(np, double);
pt->wx1 = Calloc(np, double);
pt->qy = Calloc(np, double);
pt->xlqyl = Calloc(p, double);
pt->jpvt = Calloc(p, int);
pt->work = Calloc(p*2, double);
/* pt->work = Calloc(p, double); */
pt->qraux = Calloc(p, double);
for (i=0; i<n; i++) {
pt->y[i] = NUMERIC_POINTER(y)[i];
pt->wy1[i] = NUMERIC_POINTER(wy)[i];
}
for (i=0; i<np; i++) {
pt->x[i] = NUMERIC_POINTER(x)[i];
pt->wx1[i] = NUMERIC_POINTER(WX)[i];
}
pt->set = TRUE;
return;
}
Rboolean
InstanceObjectTable::exists(const char * name, Rboolean *canCache) const {
bool found = FALSE;
checkInstance();
if (canCache) *canCache = TRUE;
if (_internal)
found = !qstrcmp(name, "this") ||
findVarInFrame(fieldEnv(), install(name)) != R_UnboundValue ||
enumValue(name) != R_UnboundValue;
if (!found)
found = methodExists(name);
if (!found) {
Property *prop = _instance->klass()->property(name);
if (prop) {
found = true;
delete prop;
}
}
return (Rboolean)found;
}
/*
Because we call this function via Rf_eval(), we end up
with an extra call on the stack when we enter recover.
*/
SEXP
stop(const char *className, const char *msg, ...)
{
char buf[10000];
SEXP error, e, ns_env, ns_name;
va_list ap;
va_start(ap, msg);
/* Rvsnprintf(buf, sizeof(buf)/sizeof(buf[0]), msg, ap); */
vsnprintf(buf, sizeof(buf)/sizeof(buf[0]), msg, ap);
va_end(ap);
PROTECT(error = mkString(buf));
/*
const char * classNames[] = {"simpleError", "error", "condition"};
PROTECT(tmp = allocVector(STRSXP, sizeof(classNames)/sizeof(classNames[0])));
for(i = 0; i < sizeof(classNames)/sizeof(classNames[0]); i++)
SET_STRING_ELT(tmp, i+1, mkChar(classNames[i]));
SET_STRING_ELT(tmp, 0, mkChar(className));
SET_CLASS(error, tmp);
*/
PROTECT(e = allocVector(LANGSXP, 2));
PROTECT(ns_name = mkString("XML"));
ns_env = R_FindNamespace(ns_name);
SETCAR(e, findVarInFrame(ns_env, Rf_install("xmlStop")));
SETCAR(CDR(e), error);
Rf_eval(e, R_GlobalEnv);
UNPROTECT(3);
/*
errorcall(error, "%s", msg);
UNPROTECT(1);
*/
return(error);
}
/* used in eval.c */
SEXP attribute_hidden R_subset3_dflt(SEXP x, SEXP input, SEXP call)
{
SEXP y, nlist;
size_t slen;
PROTECT(input);
PROTECT(x);
/* Optimisation to prevent repeated recalculation */
slen = strlen(translateChar(input));
/* The mechanism to allow a class extending "environment" */
if( IS_S4_OBJECT(x) && TYPEOF(x) == S4SXP ){
x = R_getS4DataSlot(x, ANYSXP);
if(x == R_NilValue)
errorcall(call, "$ operator not defined for this S4 class");
}
UNPROTECT(1); /* x */
PROTECT(x);
/* If this is not a list object we return NULL. */
if (isPairList(x)) {
SEXP xmatch = R_NilValue;
int havematch;
UNPROTECT(2); /* input, x */
havematch = 0;
for (y = x ; y != R_NilValue ; y = CDR(y)) {
switch(pstrmatch(TAG(y), input, slen)) {
case EXACT_MATCH:
y = CAR(y);
if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x));
return y;
case PARTIAL_MATCH:
havematch++;
xmatch = y;
break;
case NO_MATCH:
break;
}
}
if (havematch == 1) { /* unique partial match */
if(R_warn_partial_match_dollar) {
const char *st = "";
SEXP target = TAG(xmatch);
switch (TYPEOF(target)) {
case SYMSXP:
st = CHAR(PRINTNAME(target));
break;
case CHARSXP:
st = translateChar(target);
break;
}
warningcall(call, _("partial match of '%s' to '%s'"),
translateChar(input), st);
}
y = CAR(xmatch);
if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x));
return y;
}
return R_NilValue;
}
else if (isVectorList(x)) {
R_xlen_t i, n, imatch = -1;
int havematch;
nlist = getAttrib(x, R_NamesSymbol);
UNPROTECT(2); /* input, x */
n = xlength(nlist);
havematch = 0;
for (i = 0 ; i < n ; i = i + 1) {
switch(pstrmatch(STRING_ELT(nlist, i), input, slen)) {
case EXACT_MATCH:
y = VECTOR_ELT(x, i);
if (NAMED(x) > NAMED(y))
SET_NAMED(y, NAMED(x));
return y;
case PARTIAL_MATCH:
havematch++;
if (havematch == 1) {
/* partial matches can cause aliasing in eval.c:evalseq
This is overkill, but alternative ways to prevent
the aliasing appear to be even worse */
y = VECTOR_ELT(x,i);
SET_NAMED(y,2);
SET_VECTOR_ELT(x,i,y);
}
imatch = i;
break;
case NO_MATCH:
break;
}
}
if(havematch == 1) { /* unique partial match */
if(R_warn_partial_match_dollar) {
const char *st = "";
SEXP target = STRING_ELT(nlist, imatch);
switch (TYPEOF(target)) {
case SYMSXP:
st = CHAR(PRINTNAME(target));
break;
case CHARSXP:
st = translateChar(target);
break;
}
warningcall(call, _("partial match of '%s' to '%s'"),
translateChar(input), st);
}
y = VECTOR_ELT(x, imatch);
if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x));
return y;
}
return R_NilValue;
}
else if( isEnvironment(x) ){
y = findVarInFrame(x, installTrChar(input));
if( TYPEOF(y) == PROMSXP ) {
PROTECT(y);
y = eval(y, R_GlobalEnv);
UNPROTECT(1); /* y */
}
UNPROTECT(2); /* input, x */
if( y != R_UnboundValue ) {
if (NAMED(y))
SET_NAMED(y, 2);
else if (NAMED(x) > NAMED(y))
SET_NAMED(y, NAMED(x));
return(y);
}
return R_NilValue;
}
else if( isVectorAtomic(x) ){
errorcall(call, "$ operator is invalid for atomic vectors");
}
else /* e.g. a function */
errorcall(call, R_MSG_ob_nonsub, type2char(TYPEOF(x)));
UNPROTECT(2); /* input, x */
return R_NilValue;
}
void CHM_restore_common() {
SEXP rho = chm_common_env;
c.dbound = asReal(findVarInFrame(rho, dboundSym));
c.grow0 = asReal(findVarInFrame(rho, grow0Sym));
c.grow1 = asReal(findVarInFrame(rho, grow1Sym));
c.grow2 = asInteger(findVarInFrame(rho, grow2Sym));
c.maxrank = asInteger(findVarInFrame(rho, maxrankSym));
c.supernodal_switch = asReal(findVarInFrame(rho, supernodal_switchSym));
c.supernodal = asLogical(findVarInFrame(rho, supernodalSym));
c.final_asis = asLogical(findVarInFrame(rho, final_asisSym));
c.final_super = asLogical(findVarInFrame(rho, final_superSym));
c.final_ll = asLogical(findVarInFrame(rho, final_llSym));
c.final_pack = asLogical(findVarInFrame(rho, final_packSym));
c.final_monotonic = asLogical(findVarInFrame(rho, final_monotonicSym));
c.final_resymbol = asLogical(findVarInFrame(rho, final_resymbolSym));
c.prefer_zomplex = asLogical(findVarInFrame(rho, prefer_zomplexSym));
c.prefer_upper = asLogical(findVarInFrame(rho, prefer_upperSym));
c.quick_return_if_not_posdef =
asLogical(findVarInFrame(rho, quick_return_if_not_posdefSym));
c.nmethods = asInteger(findVarInFrame(rho, nmethodsSym));
c.method[0].ordering = asInteger(findVarInFrame(rho, m0_ordSym));
c.postorder = asLogical(findVarInFrame(rho, postorderSym));
}
double getScale(SEXP env) {
return( NUMERIC_POINTER( findVarInFrame(env, install("scale")) )[0] );
}
static void initialize_rlcompletion(void)
{
if(rcompgen_active >= 0) return;
/* Find if package utils is around */
if(rcompgen_active < 0) {
char *p = getenv("R_COMPLETION");
if(p && streql(p, "FALSE")) {
rcompgen_active = 0;
return;
}
/* First check if namespace is loaded */
if(findVarInFrame(R_NamespaceRegistry, install("utils"))
!= R_UnboundValue) rcompgen_active = 1;
else { /* Then try to load it */
SEXP cmdSexp, cmdexpr;
ParseStatus status;
int i;
char *p = "try(loadNamespace('rcompgen'), silent=TRUE)";
PROTECT(cmdSexp = mkString(p));
cmdexpr = PROTECT(R_ParseVector(cmdSexp, -1, &status, R_NilValue));
if(status == PARSE_OK) {
for(i = 0; i < length(cmdexpr); i++)
eval(VECTOR_ELT(cmdexpr, i), R_GlobalEnv);
}
UNPROTECT(2);
if(findVarInFrame(R_NamespaceRegistry, install("utils"))
!= R_UnboundValue) rcompgen_active = 1;
else {
rcompgen_active = 0;
return;
}
}
}
rcompgen_rho = R_FindNamespace(mkString("utils"));
RComp_assignBufferSym = install(".assignLinebuffer");
RComp_assignStartSym = install(".assignStart");
RComp_assignEndSym = install(".assignEnd");
RComp_assignTokenSym = install(".assignToken");
RComp_completeTokenSym = install(".completeToken");
RComp_getFileCompSym = install(".getFileComp");
RComp_retrieveCompsSym = install(".retrieveCompletions");
/* Tell the completer that we want a crack first. */
rl_attempted_completion_function = R_custom_completion;
/* Disable sorting of possible completions; only readline >= 6 */
#if RL_READLINE_VERSION >= 0x0600
/* if (rl_readline_version >= 0x0600) */
rl_sort_completion_matches = 0;
#endif
/* token boundaries. Includes *,+ etc, but not $,@ because those
are easier to handle at the R level if the whole thing is
available. However, this breaks filename completion if partial
filenames contain things like $, % etc. Might be possible to
associate a M-/ override like bash does. One compromise is that
we exclude / from the breakers because that is frequently found
in filenames even though it is also an operator. This can be
handled in R code (although it shouldn't be necessary if users
surround operators with spaces, as they should). */
/* FIXME: quotes currently lead to filename completion without any
further ado. This is not necessarily the best we can do, since
quotes after a [, $, [[, etc should be treated differently. I'm
not testing this now, but this should be doable by removing quote
characters from the strings below and handle it with other things
in 'specialCompletions()' in R. The problem with that approach
is that file name completion will probably have to be done
manually in R, which is not trivial. One way to go might be to
forego file name completion altogether when TAB completing, and
associate M-/ or something to filename completion (a startup
message might say so, to remind users)
All that might not be worth the pain though (vector names would
be practically impossible, to begin with) */
return;
}
SEXP attribute_hidden do_subset2_dflt(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, dims, dimnames, indx, subs, x;
int i, ndims, nsubs;
int drop = 1, pok, exact = -1;
int named_x;
R_xlen_t offset = 0;
PROTECT(args);
ExtractDropArg(args, &drop);
/* Is partial matching ok? When the exact arg is NA, a warning is
issued if partial matching occurs.
*/
exact = ExtractExactArg(args);
if (exact == -1)
pok = exact;
else
pok = !exact;
x = CAR(args);
/* This code was intended for compatibility with S, */
/* but in fact S does not do this. Will anyone notice? */
if (x == R_NilValue) {
UNPROTECT(1); /* args */
return x;
}
/* Get the subscripting and dimensioning information */
/* and check that any array subscripting is compatible. */
subs = CDR(args);
if(0 == (nsubs = length(subs)))
errorcall(call, _("no index specified"));
dims = getAttrib(x, R_DimSymbol);
ndims = length(dims);
if(nsubs > 1 && nsubs != ndims)
errorcall(call, _("incorrect number of subscripts"));
/* code to allow classes to extend environment */
if(TYPEOF(x) == S4SXP) {
x = R_getS4DataSlot(x, ANYSXP);
if(x == R_NilValue)
errorcall(call, _("this S4 class is not subsettable"));
}
PROTECT(x);
/* split out ENVSXP for now */
if( TYPEOF(x) == ENVSXP ) {
if( nsubs != 1 || !isString(CAR(subs)) || length(CAR(subs)) != 1 )
errorcall(call, _("wrong arguments for subsetting an environment"));
ans = findVarInFrame(x, installTrChar(STRING_ELT(CAR(subs), 0)));
if( TYPEOF(ans) == PROMSXP ) {
PROTECT(ans);
ans = eval(ans, R_GlobalEnv);
UNPROTECT(1); /* ans */
} else SET_NAMED(ans, 2);
UNPROTECT(2); /* args, x */
if(ans == R_UnboundValue)
return(R_NilValue);
if (NAMED(ans))
SET_NAMED(ans, 2);
return ans;
}
/* back to the regular program */
if (!(isVector(x) || isList(x) || isLanguage(x)))
errorcall(call, R_MSG_ob_nonsub, type2char(TYPEOF(x)));
named_x = NAMED(x); /* x may change below; save this now. See PR#13411 */
if(nsubs == 1) { /* vector indexing */
SEXP thesub = CAR(subs);
int len = length(thesub);
if (len > 1) {
#ifdef SWITCH_TO_REFCNT
if (IS_GETTER_CALL(call)) {
/* this is (most likely) a getter call in a complex
assighment so we duplicate as needed. The original
x should have been duplicated if it might be
shared */
if (MAYBE_SHARED(x))
error("getter call used outside of a complex assignment.");
x = vectorIndex(x, thesub, 0, len-1, pok, call, TRUE);
}
else
x = vectorIndex(x, thesub, 0, len-1, pok, call, FALSE);
#else
x = vectorIndex(x, thesub, 0, len-1, pok, call, FALSE);
#endif
named_x = NAMED(x);
UNPROTECT(1); /* x */
PROTECT(x);
}
SEXP xnames = PROTECT(getAttrib(x, R_NamesSymbol));
offset = get1index(thesub, xnames,
xlength(x), pok, len > 1 ? len-1 : -1, call);
UNPROTECT(1); /* xnames */
if (offset < 0 || offset >= xlength(x)) {
/* a bold attempt to get the same behaviour for $ and [[ */
if (offset < 0 && (isNewList(x) ||
isExpression(x) ||
isList(x) ||
isLanguage(x))) {
UNPROTECT(2); /* args, x */
return R_NilValue;
}
else errorcall(call, R_MSG_subs_o_b);
}
} else { /* matrix indexing */
/* Here we use the fact that: */
/* CAR(R_NilValue) = R_NilValue */
/* CDR(R_NilValue) = R_NilValue */
int ndn; /* Number of dimnames. Unlikely to be anything but
0 or nsubs, but just in case... */
PROTECT(indx = allocVector(INTSXP, nsubs));
dimnames = getAttrib(x, R_DimNamesSymbol);
ndn = length(dimnames);
for (i = 0; i < nsubs; i++) {
INTEGER(indx)[i] = (int)
get1index(CAR(subs),
(i < ndn) ? VECTOR_ELT(dimnames, i) : R_NilValue,
INTEGER(indx)[i], pok, -1, call);
subs = CDR(subs);
if (INTEGER(indx)[i] < 0 ||
INTEGER(indx)[i] >= INTEGER(dims)[i])
errorcall(call, R_MSG_subs_o_b);
}
offset = 0;
for (i = (nsubs - 1); i > 0; i--)
offset = (offset + INTEGER(indx)[i]) * INTEGER(dims)[i - 1];
offset += INTEGER(indx)[0];
UNPROTECT(1); /* indx */
}
if(isPairList(x)) {
#ifdef LONG_VECTOR_SUPPORT
if (offset > R_SHORT_LEN_MAX)
error("invalid subscript for pairlist");
#endif
ans = CAR(nthcdr(x, (int) offset));
if (named_x > NAMED(ans))
SET_NAMED(ans, named_x);
} else if(isVectorList(x)) {
/* did unconditional duplication before 2.4.0 */
ans = VECTOR_ELT(x, offset);
if (named_x > NAMED(ans))
SET_NAMED(ans, named_x);
} else {
ans = allocVector(TYPEOF(x), 1);
switch (TYPEOF(x)) {
case LGLSXP:
case INTSXP:
INTEGER(ans)[0] = INTEGER(x)[offset];
break;
case REALSXP:
REAL(ans)[0] = REAL(x)[offset];
break;
case CPLXSXP:
COMPLEX(ans)[0] = COMPLEX(x)[offset];
break;
case STRSXP:
SET_STRING_ELT(ans, 0, STRING_ELT(x, offset));
break;
case RAWSXP:
RAW(ans)[0] = RAW(x)[offset];
break;
default:
UNIMPLEMENTED_TYPE("do_subset2", x);
}
}
UNPROTECT(2); /* args, x */
return ans;
}
SEXP RClass::properties() const {
static SEXP propSym = install("properties");
return findVarInFrame(metadata(), propSym);
}
