The R Project SVN – R – Diff – /trunk/src/main/subscript.c



/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
 *  Copyright (C) 1997--2003  Robert Gentleman, Ross Ihaka and the
 *                            R Development Core Team
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or

    else
	error("attempt to select more than one element");
    return(indx);
}
 
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) {

		    break;
		}
	}
	if (indx == -1)
	    indx = nx;
	*newname = STRING_ELT(s, pos);
	break;
    default:
	error("invalid subscript type");
    }
    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 */
		}

Rev 15390	Rev 22883
Line 1...	Line 1...
1	`/*`	1	`/*`
2	`* R : A Computer Language for Statistical Data Analysis`	2	`* R : A Computer Language for Statistical Data Analysis`
3	`* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka`	3	`* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka`
4	`* Copyright (C) 1997--2000 Robert Gentleman, Ross Ihaka and the`	4	`* Copyright (C) 1997--2003 Robert Gentleman, Ross Ihaka and the`
5	`* R Development Core Team`	5	`* R Development Core Team`
6	`*`	6	`*`
7	`* This program is free software; you can redistribute it and/or modify`	7	`* This program is free software; you can redistribute it and/or modify`
8	`* it under the terms of the GNU General Public License as published by`	8	`* it under the terms of the GNU General Public License as published by`
9	`* the Free Software Foundation; either version 2 of the License, or`	9	`* the Free Software Foundation; either version 2 of the License, or`
Line 37...	Line 37...
37	`else`	37	`else`
38	`error("attempt to select more than one element");`	38	`error("attempt to select more than one element");`
39	`return(indx);`	39	`return(indx);`
40	`}`	40	`}`
41		41
42	`int OneIndex(SEXP x, SEXP s, int len, int partial, SEXP *newname)`	42	`int OneIndex(SEXP x, SEXP s, int len, int partial, SEXP *newname, int pos)`
43	`{`	43	`{`
44	`SEXP names;`	44	`SEXP names;`
45	`int i, indx, nx;`	45	`int i, indx, nx;`
46		46
47	`if (length(s) > 1)`	47	`if (pos < 0 && length(s) > 1)`
48	`error("attempt to select more than one element");`	48	`error("attempt to select more than one element");`
49	`if (length(s) < 1)`	49	`if (pos < 0 && length(s) < 1)`
50	`error("attempt to select less than one element");`	50	`error("attempt to select less than one element");`
-		51	`if(pos < 0) pos = 0;`
51		52
52	`indx = -1;`	53	`indx = -1;`
53	`*newname = R_NilValue;`	54	`*newname = R_NilValue;`
54	`switch(TYPEOF(s)) {`	55	`switch(TYPEOF(s)) {`
55	`case LGLSXP:`	56	`case LGLSXP:`
56	`case INTSXP:`	57	`case INTSXP:`
57	`indx = integerOneIndex(INTEGER(s)[0], len);`	58	`indx = integerOneIndex(INTEGER(s)[pos], len);`
58	`break;`	59	`break;`
59	`case REALSXP:`	60	`case REALSXP:`
60	`indx = integerOneIndex(REAL(s)[0], len);`	61	`indx = integerOneIndex(REAL(s)[pos], len);`
61	`break;`	62	`break;`
62	`case STRSXP:`	63	`case STRSXP:`
63	`nx = length(x);`	64	`nx = length(x);`
64	`names = getAttrib(x, R_NamesSymbol);`	65	`names = getAttrib(x, R_NamesSymbol);`
65	`if (names != R_NilValue) {`	66	`if (names != R_NilValue) {`
66	`/* Try for exact match */`	67	`/* Try for exact match */`
67	`for (i = 0; i < nx; i++)`	68	`for (i = 0; i < nx; i++)`
68	`if (streql(CHAR(STRING_ELT(names, i)),`	69	`if (streql(CHAR(STRING_ELT(names, i)),`
69	`CHAR(STRING_ELT(s, 0)))) {`	70	`CHAR(STRING_ELT(s, pos)))) {`
70	`indx = i;`	71	`indx = i;`
71	`break;`	72	`break;`
72	`}`	73	`}`
73	`/* Try for partial match */`	74	`/* Try for partial match */`
74	`if (partial && indx < 0) {`	75	`if (partial && indx < 0) {`
75	`len = strlen(CHAR(STRING_ELT(s, 0)));`	76	`len = strlen(CHAR(STRING_ELT(s, pos)));`
76	`for(i = 0; i < nx; i++) {`	77	`for(i = 0; i < nx; i++) {`
77	`if(!strncmp(CHAR(STRING_ELT(names, i)),`	78	`if(!strncmp(CHAR(STRING_ELT(names, i)),`
78	`CHAR(STRING_ELT(s, 0)), len)) {`	79	`CHAR(STRING_ELT(s, pos)), len)) {`
79	`if(indx == -1 )`	80	`if(indx == -1 )`
80	`indx = i;`	81	`indx = i;`
81	`else`	82	`else`
82	`indx = -2;`	83	`indx = -2;`
83	`}`	84	`}`
84	`}`	85	`}`
85	`}`	86	`}`
86	`}`	87	`}`
87	`if (indx == -1)`	88	`if (indx == -1)`
88	`indx = nx;`	89	`indx = nx;`
89	`*newname = STRING_ELT(s, 0);`	90	`*newname = STRING_ELT(s, pos);`
90	`break;`	91	`break;`
91	`case SYMSXP:`	92	`case SYMSXP:`
92	`nx = length(x);`	93	`nx = length(x);`
93	`names = getAttrib(x, R_NamesSymbol);`	94	`names = getAttrib(x, R_NamesSymbol);`
94	`if (names != R_NilValue) {`	95	`if (names != R_NilValue) {`
Line 99...	Line 100...
99	`break;`	100	`break;`
100	`}`	101	`}`
101	`}`	102	`}`
102	`if (indx == -1)`	103	`if (indx == -1)`
103	`indx = nx;`	104	`indx = nx;`
104	`*newname = STRING_ELT(s, 0);`	105	`*newname = STRING_ELT(s, pos);`
105	`break;`	106	`break;`
106	`default:`	107	`default:`
107	`error("invalid subscript type");`	108	`error("invalid subscript type");`
108	`}`	109	`}`
109	`return indx;`	110	`return indx;`
110	`}`	111	`}`
111		112
112	`int get1index(SEXP s, SEXP names, int len, Rboolean pok)`	113	`int get1index(SEXP s, SEXP names, int len, Rboolean pok, int pos)`
113	`{`	114	`{`
114	`/* Get a single index for the [[ operator.`	115	`/* Get a single index for the [[ operator.`
115	`Check that only one index is being selected.`	116	`Check that only one index is being selected.`
116	`pok : is "partial ok" ?`	117	`pok : is "partial ok" ?`
117	`*/`	118	`*/`
118	`int indx, i;`	119	`int indx, i;`
119	`double dblind;`	120	`double dblind;`
120		121
121	`if (length(s) != 1) {`	122	`if (pos < 0 && length(s) != 1) {`
122	`if (length(s) > 1)`	123	`if (length(s) > 1)`
123	`error("attempt to select more than one element");`	124	`error("attempt to select more than one element");`
124	`else`	125	`else`
125	`error("attempt to select less than one element");`	126	`error("attempt to select less than one element");`
126	`}`	127	`} else`
-		128	`if(pos >= length(s))`
-		129	`error("internal error in use of recursive indexing");`
-		130	`if(pos < 0) pos = 0;`
127	`indx = -1;`	131	`indx = -1;`
128	`switch (TYPEOF(s)) {`	132	`switch (TYPEOF(s)) {`
129	`case LGLSXP:`	133	`case LGLSXP:`
130	`case INTSXP:`	134	`case INTSXP:`
131	`i = INTEGER(s)[0];`	135	`i = INTEGER(s)[pos];`
132	`if(i != NA_INTEGER)`	136	`if(i != NA_INTEGER)`
133	`indx = integerOneIndex(i, len);`	137	`indx = integerOneIndex(i, len);`
134	`break;`	138	`break;`
135	`case REALSXP:`	139	`case REALSXP:`
136	`dblind = REAL(s)[0];`	140	`dblind = REAL(s)[pos];`
137	`if(!ISNAN(dblind))`	141	`if(!ISNAN(dblind))`
138	`indx = integerOneIndex((int)dblind, len);`	142	`indx = integerOneIndex((int)dblind, len);`
139	`break;`	143	`break;`
140	`case STRSXP:`	144	`case STRSXP:`
141	`/* Try for exact match */`	145	`/* Try for exact match */`
142	`for (i = 0; i < length(names); i++)`	146	`for (i = 0; i < length(names); i++)`
143	`if (streql(CHAR(STRING_ELT(names, i)), CHAR(STRING_ELT(s, 0)))) {`	147	`if (streql(CHAR(STRING_ELT(names, i)),`
-		148	`CHAR(STRING_ELT(s, pos)))) {`
144	`indx = i;`	149	`indx = i;`
145	`break;`	150	`break;`
146	`}`	151	`}`
147	`/* Try for partial match */`	152	`/* Try for partial match */`
148	`if (pok && indx < 0) {`	153	`if (pok && indx < 0) {`
149	`len = strlen(CHAR(STRING_ELT(s, 0)));`	154	`len = strlen(CHAR(STRING_ELT(s, pos)));`
150	`for(i = 0; i < length(names); i++) {`	155	`for(i = 0; i < length(names); i++) {`
151	`if(!strncmp(CHAR(STRING_ELT(names, i)),`	156	`if(!strncmp(CHAR(STRING_ELT(names, i)),`
152	`CHAR(STRING_ELT(s, 0)), len)) {`	157	`CHAR(STRING_ELT(s, pos)), len)) {`
153	`if(indx == -1)/* first one */`	158	`if(indx == -1)/* first one */`
154	`indx = i;`	159	`indx = i;`
155	`else`	160	`else`
156	`indx = -2;/* more than one partial match */`	161	`indx = -2;/* more than one partial match */`
157	`}`	162	`}`

The R Project SVN R

(root)/trunk/src/main/subscript.c @ 28362 – Rev 15390 → 22883