The R Project SVN – R – Diff – /branches/R-NaString/src/main/subscript.c



#endif
 
#include "Defn.h"
 
static int integerOneIndex(int i, int len) {
    int indx = -1;
 
    if (i > 0)
	indx = i - 1;
    else if (i == 0 || len < 2)
	error("attempt to select less than one element");
    else if (len == 2 && i > -3)
	indx = 2 + i;
    else
	error("attempt to select more than one element");
    return(indx);
}
 
int OneIndex(SEXP x, SEXP s, int len, int partial, SEXP *newname)
{
    SEXP names;
    int i, indx, nx;
 
    if (length(s) > 1)
	error("attempt to select more than one element");
    if (length(s) < 1)
	error("attempt to select less than one element");
 
    indx = -1;
    *newname = R_NilValue;
    switch(TYPEOF(s)) {
    case LGLSXP:
    case INTSXP:
	indx = integerOneIndex(INTEGER(s)[0], len);
	break;
    case REALSXP:
	indx = integerOneIndex(REAL(s)[0], 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, 0)))) {
		    indx = i;
		    break;
		}
	    /* Try for partial match */
	    if (partial && indx < 0) {
		len = strlen(CHAR(STRING_ELT(s, 0)));
		for(i = 0; i < nx; i++) {
		    if(!strncmp(CHAR(STRING_ELT(names, i)),
				CHAR(STRING_ELT(s, 0)), len)) {
			if(indx == -1 )
			    indx = i;
			else
			    indx = -2;
		    }
		}
	    }
	}
	if (indx == -1)
	    indx = nx;
	*newname = STRING_ELT(s, 0);
	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, 0);
	break;
    default:
	error("invalid subscript type");
    }
    return indx;
}
 
int get1index(SEXP s, SEXP names, int len, Rboolean pok)
{
/* 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 (length(s) != 1) {
	if (length(s) > 1)
	    error("attempt to select more than one element");
	else
	    error("attempt to select less than one element");
    }
    indx = -1;
    switch (TYPEOF(s)) {
    case LGLSXP:
    case INTSXP:
	i = INTEGER(s)[0];
	if(i != NA_INTEGER)
	    indx = integerOneIndex(i, len);
	break;
    case REALSXP:
	dblind = REAL(s)[0];
	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, 0)))) {
		indx = i;
		break;
	    }
	/* Try for partial match */
	if (pok && indx < 0) {
	    len = strlen(CHAR(STRING_ELT(s, 0)));
	    for(i = 0; i < length(names); i++) {
		if(!strncmp(CHAR(STRING_ELT(names, i)),
			    CHAR(STRING_ELT(s, 0)), 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;
}
 
/* Special Matrix Subscripting: Handles the case x[i] where */
/* x is an n-way array and i is a matrix with n columns. */
/* This code returns a vector containing the integer subscripts */

}
 
static SEXP nullSubscript(int n)
{
    int i;
    SEXP indx;
    indx = allocVector(INTSXP, n);
    for (i = 0; i < n; i++)
	INTEGER(indx)[i] = i + 1;
    return indx;
}
 
static SEXP logicalSubscript(SEXP s, int ns, int nx, int *stretch)
{
    int canstretch, count, i, nmax;
    SEXP indx;
    canstretch = *stretch;
#ifdef OLD
    if (ns > nx)
	error("subscript (%d) out of bounds, should be at most %d",
	      ns, nx);

#else
    for (i = 0; i < nmax; i++)
#endif
	if (LOGICAL(s)[i%ns])
	    count++;
    indx = allocVector(INTSXP, count);
    count = 0;
#ifdef OLD
    for (i = 0; i < nx; i++)
#else
    for (i = 0; i < nmax; i++)
#endif
	if (LOGICAL(s)[i%ns]) {
	    if (LOGICAL(s)[i%ns] == NA_LOGICAL)
		INTEGER(indx)[count++] = NA_INTEGER;
	    else
		INTEGER(indx)[count++] = i + 1;
	}
    return indx;
}
 
static SEXP negativeSubscript(SEXP s, int ns, int nx)
{
    SEXP indx;
    int stretch = 0;
    int i;
    PROTECT(indx = allocVector(INTSXP, nx));
    for (i = 0; i < nx; i++)
	INTEGER(indx)[i] = 1;
    for (i = 0; i < ns; i++)
	if (INTEGER(s)[i] != 0)
	    INTEGER(indx)[-INTEGER(s)[i] - 1] = 0;
    s = logicalSubscript(indx, nx, nx, &stretch);
    UNPROTECT(1);
    return s;
}
 
static SEXP positiveSubscript(SEXP s, int ns, int nx)
{
    SEXP indx;
    int i, zct = 0;
    for (i = 0; i < ns; i++) {
	if (INTEGER(s)[i] == 0)
	    zct++;
    }
    if (zct) {
	indx = allocVector(INTSXP, (ns - zct));
	for (i = 0, zct = 0; i < ns; i++)
	    if (INTEGER(s)[i] != 0)
		INTEGER(indx)[zct++] = INTEGER(s)[i];
	return indx;
    }
    else
	return s;
}
 

    return R_NilValue;
}
 
static SEXP stringSubscript(SEXP s, int ns, int nx, SEXP names, int *stretch)
{
    SEXP indx, indexnames;
    int i, j, nnames, sub, extra;
    int canstretch = *stretch;
    PROTECT(s);
    PROTECT(names);
    PROTECT(indx = allocVector(INTSXP, ns));
    PROTECT(indexnames = allocVector(STRSXP, ns));
    nnames = nx;
    extra = nnames;
 
    /* Process each of the subscripts */

		}
	}
	if (sub == 0) {
	    for (j = 0 ; j < i ; j++)
		if (NonNullStringMatch(STRING_ELT(s, i), STRING_ELT(s, j))) {
		    sub = INTEGER(indx)[j];
/*		    SET_STRING_ELT(indexnames, i, STRING_ELT(indexnames, sub - 1));*/
		    SET_STRING_ELT(indexnames, i, STRING_ELT(s, j));
		    break;
		}
	}

		error("subscript out of bounds");
	    extra += 1;
	    sub = extra;
	    SET_STRING_ELT(indexnames, i, STRING_ELT(s, i));
	}
	INTEGER(indx)[i] = sub;
    }
    /* Ghastly hack!  We attach the new names to the attribute */
    /* slot on the returned subscript vector. */
    if (extra != nnames) {
	SET_ATTRIB(indx, indexnames);
    }
    if (canstretch)
	*stretch = extra;
    UNPROTECT(4);
    return indx;
}
 
/* Array Subscripts.  dim is the dimension (0 to k-1), s is */
/* the subscript list, x is the array to be subscripted. */
 

Rev 10782	Rev 10921
Line 24...	Line 24...
24	`#endif`	24	`#endif`
25		25
26	`#include "Defn.h"`	26	`#include "Defn.h"`
27		27
28	`static int integerOneIndex(int i, int len) {`	28	`static int integerOneIndex(int i, int len) {`
29	`int index = -1;`	29	`int indx = -1;`
30		30
31	`if (i > 0)`	31	`if (i > 0)`
32	`index = i - 1;`	32	`indx = i - 1;`
33	`else if (i == 0 \|\| len < 2)`	33	`else if (i == 0 \|\| len < 2)`
34	`error("attempt to select less than one element");`	34	`error("attempt to select less than one element");`
35	`else if (len == 2 && i > -3)`	35	`else if (len == 2 && i > -3)`
36	`index = 2 + i;`	36	`indx = 2 + i;`
37	`else`	37	`else`
38	`error("attempt to select more than one element");`	38	`error("attempt to select more than one element");`
39	`return(index);`	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)`
43	`{`	43	`{`
44	`SEXP names;`	44	`SEXP names;`
45	`int i, index, nx;`	45	`int i, indx, nx;`
46		46
47	`if (length(s) > 1)`	47	`if (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 (length(s) < 1)`
50	`error("attempt to select less than one element");`	50	`error("attempt to select less than one element");`
51		51
52	`index = -1;`	52	`indx = -1;`
53	`*newname = R_NilValue;`	53	`*newname = R_NilValue;`
54	`switch(TYPEOF(s)) {`	54	`switch(TYPEOF(s)) {`
55	`case LGLSXP:`	55	`case LGLSXP:`
56	`case INTSXP:`	56	`case INTSXP:`
57	`index = integerOneIndex(INTEGER(s)[0], len);`	57	`indx = integerOneIndex(INTEGER(s)[0], len);`
58	`break;`	58	`break;`
59	`case REALSXP:`	59	`case REALSXP:`
60	`index = integerOneIndex(REAL(s)[0], len);`	60	`indx = integerOneIndex(REAL(s)[0], len);`
61	`break;`	61	`break;`
62	`case STRSXP:`	62	`case STRSXP:`
63	`nx = length(x);`	63	`nx = length(x);`
64	`names = getAttrib(x, R_NamesSymbol);`	64	`names = getAttrib(x, R_NamesSymbol);`
65	`if (names != R_NilValue) {`	65	`if (names != R_NilValue) {`
66	`/* Try for exact match */`	66	`/* Try for exact match */`
67	`for (i = 0; i < nx; i++)`	67	`for (i = 0; i < nx; i++)`
68	`if (streql(CHAR(STRING_ELT(names, i)),`	68	`if (streql(CHAR(STRING_ELT(names, i)),`
69	`CHAR(STRING_ELT(s, 0)))) {`	69	`CHAR(STRING_ELT(s, 0)))) {`
70	`index = i;`	70	`indx = i;`
71	`break;`	71	`break;`
72	`}`	72	`}`
73	`/* Try for partial match */`	73	`/* Try for partial match */`
74	`if (partial && index < 0) {`	74	`if (partial && indx < 0) {`
75	`len = strlen(CHAR(STRING_ELT(s, 0)));`	75	`len = strlen(CHAR(STRING_ELT(s, 0)));`
76	`for(i = 0; i < nx; i++) {`	76	`for(i = 0; i < nx; i++) {`
77	`if(!strncmp(CHAR(STRING_ELT(names, i)),`	77	`if(!strncmp(CHAR(STRING_ELT(names, i)),`
78	`CHAR(STRING_ELT(s, 0)), len)) {`	78	`CHAR(STRING_ELT(s, 0)), len)) {`
79	`if(index == -1 )`	79	`if(indx == -1 )`
80	`index = i;`	80	`indx = i;`
81	`else`	81	`else`
82	`index = -2;`	82	`indx = -2;`
83	`}`	83	`}`
84	`}`	84	`}`
85	`}`	85	`}`
86	`}`	86	`}`
87	`if (index == -1)`	87	`if (indx == -1)`
88	`index = nx;`	88	`indx = nx;`
89	`*newname = STRING_ELT(s, 0);`	89	`*newname = STRING_ELT(s, 0);`
90	`break;`	90	`break;`
91	`case SYMSXP:`	91	`case SYMSXP:`
92	`nx = length(x);`	92	`nx = length(x);`
93	`names = getAttrib(x, R_NamesSymbol);`	93	`names = getAttrib(x, R_NamesSymbol);`
94	`if (names != R_NilValue) {`	94	`if (names != R_NilValue) {`
95	`for (i = 0; i < nx; i++)`	95	`for (i = 0; i < nx; i++)`
96	`if (streql(CHAR(STRING_ELT(names, i)),`	96	`if (streql(CHAR(STRING_ELT(names, i)),`
97	`CHAR(PRINTNAME(s)))) {`	97	`CHAR(PRINTNAME(s)))) {`
98	`index = i;`	98	`indx = i;`
99	`break;`	99	`break;`
100	`}`	100	`}`
101	`}`	101	`}`
102	`if (index == -1)`	102	`if (indx == -1)`
103	`index = nx;`	103	`indx = nx;`
104	`*newname = STRING_ELT(s, 0);`	104	`*newname = STRING_ELT(s, 0);`
105	`break;`	105	`break;`
106	`default:`	106	`default:`
107	`error("invalid subscript type");`	107	`error("invalid subscript type");`
108	`}`	108	`}`
109	`return index;`	109	`return indx;`
110	`}`	110	`}`
111		111
112	`int get1index(SEXP s, SEXP names, int len, Rboolean pok)`	112	`int get1index(SEXP s, SEXP names, int len, Rboolean pok)`
113	`{`	113	`{`
114	`/* Get a single index for the [[ operator.`	114	`/* Get a single index for the [[ operator.`
115	`Check that only one index is being selected.`	115	`Check that only one index is being selected.`
116	`pok : is "partial ok" ?`	116	`pok : is "partial ok" ?`
117	`*/`	117	`*/`
118	`int index, i;`	118	`int indx, i;`
119	`double dblind;`	119	`double dblind;`
120		120
121	`if (length(s) != 1) {`	121	`if (length(s) != 1) {`
122	`if (length(s) > 1)`	122	`if (length(s) > 1)`
123	`error("attempt to select more than one element");`	123	`error("attempt to select more than one element");`
124	`else`	124	`else`
125	`error("attempt to select less than one element");`	125	`error("attempt to select less than one element");`
126	`}`	126	`}`
127	`index = -1;`	127	`indx = -1;`
128	`switch (TYPEOF(s)) {`	128	`switch (TYPEOF(s)) {`
129	`case LGLSXP:`	129	`case LGLSXP:`
130	`case INTSXP:`	130	`case INTSXP:`
131	`i = INTEGER(s)[0];`	131	`i = INTEGER(s)[0];`
132	`if(i != NA_INTEGER)`	132	`if(i != NA_INTEGER)`
133	`index = integerOneIndex(i, len);`	133	`indx = integerOneIndex(i, len);`
134	`break;`	134	`break;`
135	`case REALSXP:`	135	`case REALSXP:`
136	`dblind = REAL(s)[0];`	136	`dblind = REAL(s)[0];`
137	`if(!ISNAN(dblind))`	137	`if(!ISNAN(dblind))`
138	`index = integerOneIndex((int)dblind, len);`	138	`indx = integerOneIndex((int)dblind, len);`
139	`break;`	139	`break;`
140	`case STRSXP:`	140	`case STRSXP:`
141	`/* Try for exact match */`	141	`/* Try for exact match */`
142	`for (i = 0; i < length(names); i++)`	142	`for (i = 0; i < length(names); i++)`
143	`if (streql(CHAR(STRING_ELT(names, i)), CHAR(STRING_ELT(s, 0)))) {`	143	`if (streql(CHAR(STRING_ELT(names, i)), CHAR(STRING_ELT(s, 0)))) {`
144	`index = i;`	144	`indx = i;`
145	`break;`	145	`break;`
146	`}`	146	`}`
147	`/* Try for partial match */`	147	`/* Try for partial match */`
148	`if (pok && index < 0) {`	148	`if (pok && indx < 0) {`
149	`len = strlen(CHAR(STRING_ELT(s, 0)));`	149	`len = strlen(CHAR(STRING_ELT(s, 0)));`
150	`for(i = 0; i < length(names); i++) {`	150	`for(i = 0; i < length(names); i++) {`
151	`if(!strncmp(CHAR(STRING_ELT(names, i)),`	151	`if(!strncmp(CHAR(STRING_ELT(names, i)),`
152	`CHAR(STRING_ELT(s, 0)), len)) {`	152	`CHAR(STRING_ELT(s, 0)), len)) {`
153	`if(index == -1)/* first one */`	153	`if(indx == -1)/* first one */`
154	`index = i;`	154	`indx = i;`
155	`else`	155	`else`
156	`index = -2;/* more than one partial match */`	156	`indx = -2;/* more than one partial match */`
157	`}`	157	`}`
158	`}`	158	`}`
159	`}`	159	`}`
160	`break;`	160	`break;`
161	`case SYMSXP:`	161	`case SYMSXP:`
162	`for (i = 0; i < length(names); i++)`	162	`for (i = 0; i < length(names); i++)`
163	`if (streql(CHAR(STRING_ELT(names, i)), CHAR(PRINTNAME(s)))) {`	163	`if (streql(CHAR(STRING_ELT(names, i)), CHAR(PRINTNAME(s)))) {`
164	`index = i;`	164	`indx = i;`
165	`break;`	165	`break;`
166	`}`	166	`}`
167	`default:`	167	`default:`
168	`error("invalid subscript type");`	168	`error("invalid subscript type");`
169	`}`	169	`}`
170	`return index;`	170	`return indx;`
171	`}`	171	`}`
172		172
173	`/* Special Matrix Subscripting: Handles the case x[i] where */`	173	`/* Special Matrix Subscripting: Handles the case x[i] where */`
174	`/* x is an n-way array and i is a matrix with n columns. */`	174	`/* x is an n-way array and i is a matrix with n columns. */`
175	`/* This code returns a vector containing the integer subscripts */`	175	`/* This code returns a vector containing the integer subscripts */`
Line 206...	Line 206...
206	`}`	206	`}`
207		207
208	`static SEXP nullSubscript(int n)`	208	`static SEXP nullSubscript(int n)`
209	`{`	209	`{`
210	`int i;`	210	`int i;`
211	`SEXP index;`	211	`SEXP indx;`
212	`index = allocVector(INTSXP, n);`	212	`indx = allocVector(INTSXP, n);`
213	`for (i = 0; i < n; i++)`	213	`for (i = 0; i < n; i++)`
214	`INTEGER(index)[i] = i + 1;`	214	`INTEGER(indx)[i] = i + 1;`
215	`return index;`	215	`return indx;`
216	`}`	216	`}`
217		217
218	`static SEXP logicalSubscript(SEXP s, int ns, int nx, int *stretch)`	218	`static SEXP logicalSubscript(SEXP s, int ns, int nx, int *stretch)`
219	`{`	219	`{`
220	`int canstretch, count, i, nmax;`	220	`int canstretch, count, i, nmax;`
221	`SEXP index;`	221	`SEXP indx;`
222	`canstretch = *stretch;`	222	`canstretch = *stretch;`
223	`#ifdef OLD`	223	`#ifdef OLD`
224	`if (ns > nx)`	224	`if (ns > nx)`
225	`error("subscript (%d) out of bounds, should be at most %d",`	225	`error("subscript (%d) out of bounds, should be at most %d",`
226	`ns, nx);`	226	`ns, nx);`
Line 238...	Line 238...
238	`#else`	238	`#else`
239	`for (i = 0; i < nmax; i++)`	239	`for (i = 0; i < nmax; i++)`
240	`#endif`	240	`#endif`
241	`if (LOGICAL(s)[i%ns])`	241	`if (LOGICAL(s)[i%ns])`
242	`count++;`	242	`count++;`
243	`index = allocVector(INTSXP, count);`	243	`indx = allocVector(INTSXP, count);`
244	`count = 0;`	244	`count = 0;`
245	`#ifdef OLD`	245	`#ifdef OLD`
246	`for (i = 0; i < nx; i++)`	246	`for (i = 0; i < nx; i++)`
247	`#else`	247	`#else`
248	`for (i = 0; i < nmax; i++)`	248	`for (i = 0; i < nmax; i++)`
249	`#endif`	249	`#endif`
250	`if (LOGICAL(s)[i%ns]) {`	250	`if (LOGICAL(s)[i%ns]) {`
251	`if (LOGICAL(s)[i%ns] == NA_LOGICAL)`	251	`if (LOGICAL(s)[i%ns] == NA_LOGICAL)`
252	`INTEGER(index)[count++] = NA_INTEGER;`	252	`INTEGER(indx)[count++] = NA_INTEGER;`
253	`else`	253	`else`
254	`INTEGER(index)[count++] = i + 1;`	254	`INTEGER(indx)[count++] = i + 1;`
255	`}`	255	`}`
256	`return index;`	256	`return indx;`
257	`}`	257	`}`
258		258
259	`static SEXP negativeSubscript(SEXP s, int ns, int nx)`	259	`static SEXP negativeSubscript(SEXP s, int ns, int nx)`
260	`{`	260	`{`
261	`SEXP index;`	261	`SEXP indx;`
262	`int stretch = 0;`	262	`int stretch = 0;`
263	`int i;`	263	`int i;`
264	`PROTECT(index = allocVector(INTSXP, nx));`	264	`PROTECT(indx = allocVector(INTSXP, nx));`
265	`for (i = 0; i < nx; i++)`	265	`for (i = 0; i < nx; i++)`
266	`INTEGER(index)[i] = 1;`	266	`INTEGER(indx)[i] = 1;`
267	`for (i = 0; i < ns; i++)`	267	`for (i = 0; i < ns; i++)`
268	`if (INTEGER(s)[i] != 0)`	268	`if (INTEGER(s)[i] != 0)`
269	`INTEGER(index)[-INTEGER(s)[i] - 1] = 0;`	269	`INTEGER(indx)[-INTEGER(s)[i] - 1] = 0;`
270	`s = logicalSubscript(index, nx, nx, &stretch);`	270	`s = logicalSubscript(indx, nx, nx, &stretch);`
271	`UNPROTECT(1);`	271	`UNPROTECT(1);`
272	`return s;`	272	`return s;`
273	`}`	273	`}`
274		274
275	`static SEXP positiveSubscript(SEXP s, int ns, int nx)`	275	`static SEXP positiveSubscript(SEXP s, int ns, int nx)`
276	`{`	276	`{`
277	`SEXP index;`	277	`SEXP indx;`
278	`int i, zct = 0;`	278	`int i, zct = 0;`
279	`for (i = 0; i < ns; i++) {`	279	`for (i = 0; i < ns; i++) {`
280	`if (INTEGER(s)[i] == 0)`	280	`if (INTEGER(s)[i] == 0)`
281	`zct++;`	281	`zct++;`
282	`}`	282	`}`
283	`if (zct) {`	283	`if (zct) {`
284	`index = allocVector(INTSXP, (ns - zct));`	284	`indx = allocVector(INTSXP, (ns - zct));`
285	`for (i = 0, zct = 0; i < ns; i++)`	285	`for (i = 0, zct = 0; i < ns; i++)`
286	`if (INTEGER(s)[i] != 0)`	286	`if (INTEGER(s)[i] != 0)`
287	`INTEGER(index)[zct++] = INTEGER(s)[i];`	287	`INTEGER(indx)[zct++] = INTEGER(s)[i];`
288	`return index;`	288	`return indx;`
289	`}`	289	`}`
290	`else`	290	`else`
291	`return s;`	291	`return s;`
292	`}`	292	`}`
293		293
Line 321...	Line 321...
321	`return R_NilValue;`	321	`return R_NilValue;`
322	`}`	322	`}`
323		323
324	`static SEXP stringSubscript(SEXP s, int ns, int nx, SEXP names, int *stretch)`	324	`static SEXP stringSubscript(SEXP s, int ns, int nx, SEXP names, int *stretch)`
325	`{`	325	`{`
326	`SEXP index, indexnames;`	326	`SEXP indx, indexnames;`
327	`int i, j, nnames, sub, extra;`	327	`int i, j, nnames, sub, extra;`
328	`int canstretch = *stretch;`	328	`int canstretch = *stretch;`
329	`PROTECT(s);`	329	`PROTECT(s);`
330	`PROTECT(names);`	330	`PROTECT(names);`
331	`PROTECT(index = allocVector(INTSXP, ns));`	331	`PROTECT(indx = allocVector(INTSXP, ns));`
332	`PROTECT(indexnames = allocVector(STRSXP, ns));`	332	`PROTECT(indexnames = allocVector(STRSXP, ns));`
333	`nnames = nx;`	333	`nnames = nx;`
334	`extra = nnames;`	334	`extra = nnames;`
335		335
336	`/* Process each of the subscripts */`	336	`/* Process each of the subscripts */`
Line 349...	Line 349...
349	`}`	349	`}`
350	`}`	350	`}`
351	`if (sub == 0) {`	351	`if (sub == 0) {`
352	`for (j = 0 ; j < i ; j++)`	352	`for (j = 0 ; j < i ; j++)`
353	`if (NonNullStringMatch(STRING_ELT(s, i), STRING_ELT(s, j))) {`	353	`if (NonNullStringMatch(STRING_ELT(s, i), STRING_ELT(s, j))) {`
354	`sub = INTEGER(index)[j];`	354	`sub = INTEGER(indx)[j];`
355	`/* SET_STRING_ELT(indexnames, i, STRING_ELT(indexnames, sub - 1));*/`	355	`/* SET_STRING_ELT(indexnames, i, STRING_ELT(indexnames, sub - 1));*/`
356	`SET_STRING_ELT(indexnames, i, STRING_ELT(s, j));`	356	`SET_STRING_ELT(indexnames, i, STRING_ELT(s, j));`
357	`break;`	357	`break;`
358	`}`	358	`}`
359	`}`	359	`}`
Line 362...	Line 362...
362	`error("subscript out of bounds");`	362	`error("subscript out of bounds");`
363	`extra += 1;`	363	`extra += 1;`
364	`sub = extra;`	364	`sub = extra;`
365	`SET_STRING_ELT(indexnames, i, STRING_ELT(s, i));`	365	`SET_STRING_ELT(indexnames, i, STRING_ELT(s, i));`
366	`}`	366	`}`
367	`INTEGER(index)[i] = sub;`	367	`INTEGER(indx)[i] = sub;`
368	`}`	368	`}`
369	`/* Ghastly hack! We attach the new names to the attribute */`	369	`/* Ghastly hack! We attach the new names to the attribute */`
370	`/* slot on the returned subscript vector. */`	370	`/* slot on the returned subscript vector. */`
371	`if (extra != nnames) {`	371	`if (extra != nnames) {`
372	`SET_ATTRIB(index, indexnames);`	372	`SET_ATTRIB(indx, indexnames);`
373	`}`	373	`}`
374	`if (canstretch)`	374	`if (canstretch)`
375	`*stretch = extra;`	375	`*stretch = extra;`
376	`UNPROTECT(4);`	376	`UNPROTECT(4);`
377	`return index;`	377	`return indx;`
378	`}`	378	`}`
379		379
380	`/* Array Subscripts. dim is the dimension (0 to k-1), s is */`	380	`/* Array Subscripts. dim is the dimension (0 to k-1), s is */`
381	`/* the subscript list, x is the array to be subscripted. */`	381	`/* the subscript list, x is the array to be subscripted. */`
382		382

The R Project SVN R

(root)/branches/R-NaString/src/main/subscript.c @ 28362 – Rev 10782 → 10921