int OneIndex(SEXP x, SEXP s, int len, int partial, SEXP *newname, int pos)
{
SEXP names;
int i, indx, nx;
if (pos < 0 && length(s) > 1)
error(_("attempt to select more than one element"));
if (pos < 0 && length(s) < 1)
error(_("attempt to select less than one element"));
if(pos < 0) pos = 0;
indx = -1;
*newname = R_NilValue;
switch(TYPEOF(s)) {
case LGLSXP:
case INTSXP:
indx = integerOneIndex(INTEGER(s)[pos], len);
break;
case REALSXP:
indx = integerOneIndex(REAL(s)[pos], len);
break;
case STRSXP:
nx = length(x);
names = getAttrib(x, R_NamesSymbol);
if (names != R_NilValue) {
/* Try for exact match */
for (i = 0; i < nx; i++)
if (streql(CHAR(STRING_ELT(names, i)),
CHAR(STRING_ELT(s, pos)))) {
indx = i;
break;
}
/* Try for partial match */
if (partial && indx < 0) {
len = strlen(CHAR(STRING_ELT(s, pos)));
for(i = 0; i < nx; i++) {
if(!strncmp(CHAR(STRING_ELT(names, i)),
CHAR(STRING_ELT(s, pos)), len)) {
if(indx == -1 )
indx = i;
else
indx = -2;
}
}
}
}
if (indx == -1)
indx = nx;
*newname = STRING_ELT(s, pos);
break;
case SYMSXP:
nx = length(x);
names = getAttrib(x, R_NamesSymbol);
if (names != R_NilValue) {
for (i = 0; i < nx; i++)
if (streql(CHAR(STRING_ELT(names, i)),
CHAR(PRINTNAME(s)))) {
indx = i;
break;
}
}
if (indx == -1)
indx = nx;
*newname = STRING_ELT(s, pos);
break;
default:
error(_("invalid subscript type"));
}
return indx;
}
/* Utility used (only in) do_subassign2_dflt(), i.e. "[[<-" in ./subassign.c : */
R_xlen_t attribute_hidden
OneIndex(SEXP x, SEXP s, R_xlen_t len, int partial, SEXP *newname,
int pos, SEXP call)
{
SEXP names;
R_xlen_t i, indx, nx;
const void *vmax;
if (pos < 0 && length(s) > 1) {
ECALL(call, _("attempt to select more than one element"));
}
if (pos < 0 && length(s) < 1) {
ECALL(call, _("attempt to select less than one element"));
}
if(pos < 0) pos = 0;
indx = -1;
*newname = R_NilValue;
switch(TYPEOF(s)) {
case LGLSXP:
case INTSXP:
indx = integerOneIndex(INTEGER(s)[pos], len, call);
break;
case REALSXP:
indx = integerOneIndex((int)REAL(s)[pos], len, call);
break;
case STRSXP:
vmax = vmaxget();
nx = xlength(x);
names = PROTECT(getAttrib(x, R_NamesSymbol));
if (names != R_NilValue) {
/* Try for exact match */
for (i = 0; i < nx; i++) {
const char *tmp = translateChar(STRING_ELT(names, i));
if (!tmp[0]) continue;
if (streql(tmp, translateChar(STRING_ELT(s, pos)))) {
indx = i;
break;
}
}
/* Try for partial match */
if (partial && indx < 0) {
size_t l = strlen(translateChar(STRING_ELT(s, pos)));
for(i = 0; i < nx; i++) {
const char *tmp = translateChar(STRING_ELT(names, i));
if (!tmp[0]) continue;
if(!strncmp(tmp, translateChar(STRING_ELT(s, pos)), l)) {
if(indx == -1 )
indx = i;
else
indx = -2;
}
}
}
}
UNPROTECT(1); /* names */
if (indx == -1)
indx = nx;
*newname = STRING_ELT(s, pos);
vmaxset(vmax);
break;
case SYMSXP:
vmax = vmaxget();
nx = xlength(x);
names = getAttrib(x, R_NamesSymbol);
if (names != R_NilValue) {
PROTECT(names);
for (i = 0; i < nx; i++)
if (streql(translateChar(STRING_ELT(names, i)),
translateChar(PRINTNAME(s)))) {
indx = i;
break;
}
UNPROTECT(1); /* names */
}
if (indx == -1)
indx = nx;
*newname = STRING_ELT(s, pos);
vmaxset(vmax);
break;
default:
if (call == R_NilValue)
error(_("invalid subscript type '%s'"), type2char(TYPEOF(s)));
else
errorcall(call, _("invalid subscript type '%s'"),
type2char(TYPEOF(s)));
}
return indx;
}
int get1index(SEXP s, SEXP names, int len, Rboolean pok, int pos)
{
/* Get a single index for the [[ operator.
Check that only one index is being selected.
pok : is "partial ok" ?
*/
int indx, i;
double dblind;
if (pos < 0 && length(s) != 1) {
if (length(s) > 1)
error(_("attempt to select more than one element"));
else
error(_("attempt to select less than one element"));
} else
if(pos >= length(s))
error(_("internal error in use of recursive indexing"));
if(pos < 0) pos = 0;
indx = -1;
switch (TYPEOF(s)) {
case LGLSXP:
case INTSXP:
i = INTEGER(s)[pos];
if(i != NA_INTEGER)
indx = integerOneIndex(i, len);
break;
case REALSXP:
dblind = REAL(s)[pos];
if(!ISNAN(dblind))
indx = integerOneIndex((int)dblind, len);
break;
case STRSXP:
/* Try for exact match */
for (i = 0; i < length(names); i++)
if (streql(CHAR(STRING_ELT(names, i)),
CHAR(STRING_ELT(s, pos)))) {
indx = i;
break;
}
/* Try for partial match */
if (pok && indx < 0) {
len = strlen(CHAR(STRING_ELT(s, pos)));
for(i = 0; i < length(names); i++) {
if(!strncmp(CHAR(STRING_ELT(names, i)),
CHAR(STRING_ELT(s, pos)), len)) {
if(indx == -1)/* first one */
indx = i;
else
indx = -2;/* more than one partial match */
}
}
}
break;
case SYMSXP:
for (i = 0; i < length(names); i++)
if (streql(CHAR(STRING_ELT(names, i)), CHAR(PRINTNAME(s)))) {
indx = i;
break;
}
default:
error(_("invalid subscript type"));
}
return indx;
}
/* used here and in subset.c and subassign.c */
R_xlen_t attribute_hidden
get1index(SEXP s, SEXP names, R_xlen_t len, int pok, int pos, SEXP call)
{
/* Get a single index for the [[ and [[<- operators.
Checks that only one index is being selected.
Returns -1 for no match.
s is the subscript
len is the length of the object or dimension, with names its (dim)names.
pos is len-1 or -1 for [[, -1 for [[<-
-1 means use the only element of length-1 s.
pok : is "partial ok" ?
if pok is -1, warn if partial matching occurs, but allow.
*/
int warn_pok = 0;
const char *ss, *cur_name;
R_xlen_t indx;
const void *vmax;
if (pok == -1) {
pok = 1;
warn_pok = 1;
}
if (pos < 0 && length(s) != 1) {
if (length(s) > 1) {
ECALL(call, _("attempt to select more than one element"));
} else {
ECALL(call, _("attempt to select less than one element"));
}
} else
if(pos >= length(s)) {
ECALL(call, _("internal error in use of recursive indexing"));
}
if(pos < 0) pos = 0;
indx = -1;
switch (TYPEOF(s)) {
case LGLSXP:
case INTSXP:
{
int i = INTEGER(s)[pos];
if (i != NA_INTEGER)
indx = integerOneIndex(i, len, call);
break;
}
case REALSXP:
{
double dblind = REAL(s)[pos];
if(!ISNAN(dblind)) {
/* see comment above integerOneIndex */
if (dblind > 0) indx = (R_xlen_t)(dblind - 1);
else if (dblind == 0 || len < 2) {
ECALL(call, _("attempt to select less than one element"));
} else if (len == 2 && dblind > -3)
indx = (R_xlen_t)(2 + dblind);
else {
ECALL(call, _("attempt to select more than one element"));
}
}
break;
}
case STRSXP:
/* NA matches nothing */
if(STRING_ELT(s, pos) == NA_STRING) break;
/* "" matches nothing: see names.Rd */
if(!CHAR(STRING_ELT(s, pos))[0]) break;
/* Try for exact match */
vmax = vmaxget();
ss = translateChar(STRING_ELT(s, pos));
for (R_xlen_t i = 0; i < xlength(names); i++)
if (STRING_ELT(names, i) != NA_STRING) {
if (streql(translateChar(STRING_ELT(names, i)), ss)) {
indx = i;
break;
}
}
/* Try for partial match */
if (pok && indx < 0) {
size_t len = strlen(ss);
for(R_xlen_t i = 0; i < xlength(names); i++) {
if (STRING_ELT(names, i) != NA_STRING) {
cur_name = translateChar(STRING_ELT(names, i));
if(!strncmp(cur_name, ss, len)) {
if(indx == -1) {/* first one */
indx = i;
if (warn_pok) {
if (call == R_NilValue)
warning(_("partial match of '%s' to '%s'"),
ss, cur_name);
else
warningcall(call,
_("partial match of '%s' to '%s'"),
ss, cur_name);
}
}
else {
indx = -2;/* more than one partial match */
if (warn_pok) /* already given context */
warningcall(R_NilValue,
_("further partial match of '%s' to '%s'"),
ss, cur_name);
break;
}
}
}
}
}
vmaxset(vmax);
break;
case SYMSXP:
vmax = vmaxget();
for (R_xlen_t i = 0; i < xlength(names); i++)
if (STRING_ELT(names, i) != NA_STRING &&
streql(translateChar(STRING_ELT(names, i)),
CHAR(PRINTNAME(s)))) {
indx = i;
vmaxset(vmax);
break;
}
default:
if (call == R_NilValue)
error(_("invalid subscript type '%s'"), type2char(TYPEOF(s)));
else
errorcall(call, _("invalid subscript type '%s'"),
type2char(TYPEOF(s)));
}
return indx;
}
