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



 
/* This uses a couple of horrible hacks in conjunction with
 * VectorAssign (in subassign.c).  If subscripting is used for
 * assignment, it is possible to extend a vector by supplying new
 * names, and we want to give the extended vector those names, so they
 * are returned as the use.names attribute. Also, unset elements of the vector
 * of new names (places where a match was found) are indicated by
 * setting the element of the newnames vector to NULL.
 
*/
 
/* The original code (pre 2.0.0) used a ns x nx loop that was too
 * slow.  So now we hash.  Hashing is expensive on memory (up to 32nx
 * bytes) so it is only worth doing if ns * nx is large.  If nx is

    /* product may overflow, so check factors as well. */
    Rboolean usehashing = in && ( ((ns > 1000 && nx) || (nx > 1000 && ns)) || (ns * nx > 15*nx + ns) );
 
    PROTECT(s);
    PROTECT(names);
    PROTECT(indexnames = allocVector(VECSXP, ns));
    nnames = nx;
    extra = nnames;
 
    /* Process each of the subscripts. First we compare with the names
     * on the vector and then (if there is no match) with each of the

	PROTECT(indx = match(names, s, 0));
	/* second pass to correct this */
	for (i = 0; i < ns; i++)
	    if(STRING_ELT(s, i) == NA_STRING || !CHAR(STRING_ELT(s, i))[0])
		INTEGER(indx)[i] = 0;
 
	for (i = 0; i < ns; i++) SET_VECTOR_ELT(indexnames, i, R_NilValue);
    } else {
	PROTECT(indx = allocVector(INTSXP, ns));
	for (i = 0; i < ns; i++) {
	    sub = 0;
	    if (names != R_NilValue) {

		    if (!in && TYPEOF(names_j) != CHARSXP) {
			ECALL(call, _("character vector element does not have type CHARSXP"));
		    }
		    if (NonNullStringMatch(STRING_ELT(s, i), names_j)) {
			sub = j + 1;
 
			SET_VECTOR_ELT(indexnames, i, R_NilValue);
			break;
		    }
		}
	    }
	    INTEGER(indx)[i] = sub;

	sub = INTEGER(indx)[i];
	if (sub == 0) {
	    for (j = 0 ; j < i ; j++)
		if (NonNullStringMatch(STRING_ELT(s, i), STRING_ELT(s, j))) {
		    sub = INTEGER(indx)[j];
		    SET_VECTOR_ELT(indexnames, i, STRING_ELT(s, j));
		    break;
		}
	}
	if (sub == 0) {
	    if (!canstretch) {
		ECALL(call, _("subscript out of bounds"));
	    }
	    extra += 1;
	    sub = extra;
	    SET_VECTOR_ELT(indexnames, i, STRING_ELT(s, i));
	}
	INTEGER(indx)[i] = sub;
    }
    /* We return the new names as the names attribute of the returned
       subscript vector. */
    if (extra != nnames)
	setAttrib(indx, R_UseNamesSymbol, indexnames);
    if (canstretch)
	*stretch = extra;
    UNPROTECT(4);
    return indx;
}

Rev 50896	Rev 51067
Line 468...	Line 468...
468		468
469	`/* This uses a couple of horrible hacks in conjunction with`	469	`/* This uses a couple of horrible hacks in conjunction with`
470	`* VectorAssign (in subassign.c). If subscripting is used for`	470	`* VectorAssign (in subassign.c). If subscripting is used for`
471	`* assignment, it is possible to extend a vector by supplying new`	471	`* assignment, it is possible to extend a vector by supplying new`
472	`* names, and we want to give the extended vector those names, so they`	472	`* names, and we want to give the extended vector those names, so they`
473	`* are returned as the attribute. Also, unset elements of the vector`	473	`* are returned as the use.names attribute. Also, unset elements of the vector`
474	`* of new names (places where a match was found) are indicated by`	474	`* of new names (places where a match was found) are indicated by`
475	`* setting the element of the newnames vector to NULL, even though it`	475	`* setting the element of the newnames vector to NULL.`
476	`* is a character vector.`	-
477	`*/`	476	`*/`
478		477
479	`/* The original code (pre 2.0.0) used a ns x nx loop that was too`	478	`/* The original code (pre 2.0.0) used a ns x nx loop that was too`
480	`* slow. So now we hash. Hashing is expensive on memory (up to 32nx`	479	`* slow. So now we hash. Hashing is expensive on memory (up to 32nx`
481	`* bytes) so it is only worth doing if ns * nx is large. If nx is`	480	`* bytes) so it is only worth doing if ns * nx is large. If nx is`
Line 492...	Line 491...
492	`/* product may overflow, so check factors as well. */`	491	`/* product may overflow, so check factors as well. */`
493	`Rboolean usehashing = in && ( ((ns > 1000 && nx) \|\| (nx > 1000 && ns)) \|\| (ns * nx > 15*nx + ns) );`	492	`Rboolean usehashing = in && ( ((ns > 1000 && nx) \|\| (nx > 1000 && ns)) \|\| (ns * nx > 15*nx + ns) );`
494		493
495	`PROTECT(s);`	494	`PROTECT(s);`
496	`PROTECT(names);`	495	`PROTECT(names);`
497	`PROTECT(indexnames = allocVector(STRSXP, ns));`	496	`PROTECT(indexnames = allocVector(VECSXP, ns));`
498	`nnames = nx;`	497	`nnames = nx;`
499	`extra = nnames;`	498	`extra = nnames;`
500		499
501	`/* Process each of the subscripts. First we compare with the names`	500	`/* Process each of the subscripts. First we compare with the names`
502	`* on the vector and then (if there is no match) with each of the`	501	`* on the vector and then (if there is no match) with each of the`
Line 512...	Line 511...
512	`PROTECT(indx = match(names, s, 0));`	511	`PROTECT(indx = match(names, s, 0));`
513	`/* second pass to correct this */`	512	`/* second pass to correct this */`
514	`for (i = 0; i < ns; i++)`	513	`for (i = 0; i < ns; i++)`
515	`if(STRING_ELT(s, i) == NA_STRING \|\| !CHAR(STRING_ELT(s, i))[0])`	514	`if(STRING_ELT(s, i) == NA_STRING \|\| !CHAR(STRING_ELT(s, i))[0])`
516	`INTEGER(indx)[i] = 0;`	515	`INTEGER(indx)[i] = 0;`
517	`/* FIXME: this should not be allowed, CHARSXPs only */`	-
518	`for (i = 0; i < ns; i++) SET_STRING_ELT(indexnames, i, R_NilValue);`	516	`for (i = 0; i < ns; i++) SET_VECTOR_ELT(indexnames, i, R_NilValue);`
519	`} else {`	517	`} else {`
520	`PROTECT(indx = allocVector(INTSXP, ns));`	518	`PROTECT(indx = allocVector(INTSXP, ns));`
521	`for (i = 0; i < ns; i++) {`	519	`for (i = 0; i < ns; i++) {`
522	`sub = 0;`	520	`sub = 0;`
523	`if (names != R_NilValue) {`	521	`if (names != R_NilValue) {`
Line 526...	Line 524...
526	`if (!in && TYPEOF(names_j) != CHARSXP) {`	524	`if (!in && TYPEOF(names_j) != CHARSXP) {`
527	`ECALL(call, _("character vector element does not have type CHARSXP"));`	525	`ECALL(call, _("character vector element does not have type CHARSXP"));`
528	`}`	526	`}`
529	`if (NonNullStringMatch(STRING_ELT(s, i), names_j)) {`	527	`if (NonNullStringMatch(STRING_ELT(s, i), names_j)) {`
530	`sub = j + 1;`	528	`sub = j + 1;`
531	`/* FIXME: this should not be allowed, CHARSXPs only */`	-
532	`SET_STRING_ELT(indexnames, i, R_NilValue);`	529	`SET_VECTOR_ELT(indexnames, i, R_NilValue);`
533	`break;`	530	`break;`
534	`}`	531	`}`
535	`}`	532	`}`
536	`}`	533	`}`
537	`INTEGER(indx)[i] = sub;`	534	`INTEGER(indx)[i] = sub;`
Line 543...	Line 540...
543	`sub = INTEGER(indx)[i];`	540	`sub = INTEGER(indx)[i];`
544	`if (sub == 0) {`	541	`if (sub == 0) {`
545	`for (j = 0 ; j < i ; j++)`	542	`for (j = 0 ; j < i ; j++)`
546	`if (NonNullStringMatch(STRING_ELT(s, i), STRING_ELT(s, j))) {`	543	`if (NonNullStringMatch(STRING_ELT(s, i), STRING_ELT(s, j))) {`
547	`sub = INTEGER(indx)[j];`	544	`sub = INTEGER(indx)[j];`
548	`SET_STRING_ELT(indexnames, i, STRING_ELT(s, j));`	545	`SET_VECTOR_ELT(indexnames, i, STRING_ELT(s, j));`
549	`break;`	546	`break;`
550	`}`	547	`}`
551	`}`	548	`}`
552	`if (sub == 0) {`	549	`if (sub == 0) {`
553	`if (!canstretch) {`	550	`if (!canstretch) {`
554	`ECALL(call, _("subscript out of bounds"));`	551	`ECALL(call, _("subscript out of bounds"));`
555	`}`	552	`}`
556	`extra += 1;`	553	`extra += 1;`
557	`sub = extra;`	554	`sub = extra;`
558	`SET_STRING_ELT(indexnames, i, STRING_ELT(s, i));`	555	`SET_VECTOR_ELT(indexnames, i, STRING_ELT(s, i));`
559	`}`	556	`}`
560	`INTEGER(indx)[i] = sub;`	557	`INTEGER(indx)[i] = sub;`
561	`}`	558	`}`
562	`/* We return the new names as the names attribute of the returned`	559	`/* We return the new names as the names attribute of the returned`
563	`subscript vector. */`	560	`subscript vector. */`
564	`if (extra != nnames)`	561	`if (extra != nnames)`
565	`setAttrib(indx, R_NamesSymbol, indexnames);`	562	`setAttrib(indx, R_UseNamesSymbol, indexnames);`
566	`if (canstretch)`	563	`if (canstretch)`
567	`*stretch = extra;`	564	`*stretch = extra;`
568	`UNPROTECT(4);`	565	`UNPROTECT(4);`
569	`return indx;`	566	`return indx;`
570	`}`	567	`}`

The R Project SVN R

(root)/branches/R-exp-R5/src/main/subscript.c @ 77458 – Rev 50896 → 51067