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



    SEXP X, XX, FUN;
    X = checkArgIsSymbol(CAR(args));
    XX = PROTECT(eval(CAR(args), rho));
    R_xlen_t n = xlength(XX);  // a vector, so will be valid.
    FUN = checkArgIsSymbol(CADR(args));
    bool realIndx = n > INT_MAX;
 
    SEXP ans = PROTECT(allocVector(VECSXP, n));
    SEXP names = getAttrib(XX, R_NamesSymbol);
    if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
 

    SEXP R_fcall, ans, names = R_NilValue, rowNames = R_NilValue,
	X, XX, FUN, value, dim_v;
    R_xlen_t i, n;
    int commonLen;
    int useNames, rnk_v = -1; // = array_rank(value) := length(dim(value))
    bool array_value;
    SEXPTYPE commonType;
    PROTECT_INDEX index = 0; /* initialize to avoid a warning */
 
    checkArity(op, args);
    PROTECT(X = CAR(args));

    // FIXME: does not protect against length > 1
    if (useNames == NA_LOGICAL) error(_("invalid '%s' value"), "USE.NAMES");
 
    n = xlength(XX);
    if (n == NA_INTEGER) error(_("invalid length"));
    bool realIndx = n > INT_MAX;
 
    commonLen = length(value);
    if (commonLen > 1 && n > INT_MAX)
	error(_("long vectors are not supported for matrix/array results"));
    commonType = TYPEOF(value);

	    if (length(val) != commonLen)
		error(_("values must be length %d,\n but FUN(X[[%lld]]) result is length %d"),
		       commonLen, (long long)i+1, length(val));
	    valType = TYPEOF(val);
	    if (valType != commonType) {
		bool okay = false;
		switch (commonType) {
		case CPLXSXP: okay = (valType == REALSXP) || (valType == INTSXP)
				    || (valType == LGLSXP); break;
		case REALSXP: okay = (valType == INTSXP) || (valType == LGLSXP); break;
		case INTSXP:  okay = (valType == LGLSXP); break;

    return ans;
}
 
//  Apply FUN() to X recursively;  workhorse of rapply()
static SEXP do_one(SEXP X, SEXP FUN, SEXP classes, SEXP deflt,
		   bool replace, SEXP rho)
{
    SEXP ans, names, klass;
    bool matched = false;
 
    /* if X is a list, recurse.  Otherwise if it matches classes call f */
    if(X == R_NilValue || isVectorList(X)) {
	R_xlen_t n = xlength(X);
	if (replace) {

					  deflt, replace, rho));
	UNPROTECT(1);
	return ans;
    }
    if(strcmp(CHAR(STRING_ELT(classes, 0)), "ANY") == 0) /* ASCII */
	matched = true;
    else {
	PROTECT(klass = R_data_class(X, false));
	for(int i = 0; i < LENGTH(klass); i++)
	    for(int j = 0; j < length(classes); j++)
		if(Seql(STRING_ELT(klass, i), STRING_ELT(classes, j)))
		    matched = true;
	UNPROTECT(1);
    }
    if(matched) {
	/* This stores value to which the function is to be applied in
	   a variable X in the environment of the rapply closure call

    classes = CAR(args); args = CDR(args);
    if(!isString(classes)) error(_("invalid '%s' argument"), "classes");
    deflt = CAR(args); args = CDR(args);
    how = CAR(args);
    if(!isString(how)) error(_("invalid '%s' argument"), "how");
    bool replace = strcmp(CHAR(STRING_ELT(how, 0)), "replace") == 0; /* ASCII */
    R_xlen_t n = xlength(X);
    if (replace) {
      PROTECT(ans = shallow_duplicate(X));
    } else {
      PROTECT(ans = allocVector(VECSXP, n));

    case EXPRSXP: {
	int n = LENGTH(X), ans = NA_LOGICAL;
	for(int i = 0; i < n; i++) {
	    int isLF = islistfactor(VECTOR_ELT(X, i));
	    if(!isLF)
		return false;
	    else if(isLF == true)
		ans = true;
	    // else isLF is NA
	}
	return ans;
    }
    default:

// currently only called from unlist()
attribute_hidden SEXP do_islistfactor(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    checkArity(op, args);
    SEXP X = CAR(args);
    bool recursive = asBool2(CADR(args), call);
    int n = length(X);
    if(n == 0 || !isVectorList(X))
	return ScalarLogical(false);
 
    if(!recursive) {
	for(int i = 0; i < n; i++)
	    if(!isFactor(VECTOR_ELT(X, i)))
		return ScalarLogical(false);
 
	return ScalarLogical(true);
    }
    else { // recursive:  isVectorList(X) <==> X is VECSXP or EXPRSXP
	return ScalarLogical((islistfactor(X) == true) ? true : false);
    }
}

Rev 87838	Rev 87863
Line 46...	Line 46...
46	`SEXP X, XX, FUN;`	46	`SEXP X, XX, FUN;`
47	`X = checkArgIsSymbol(CAR(args));`	47	`X = checkArgIsSymbol(CAR(args));`
48	`XX = PROTECT(eval(CAR(args), rho));`	48	`XX = PROTECT(eval(CAR(args), rho));`
49	`R_xlen_t n = xlength(XX); // a vector, so will be valid.`	49	`R_xlen_t n = xlength(XX); // a vector, so will be valid.`
50	`FUN = checkArgIsSymbol(CADR(args));`	50	`FUN = checkArgIsSymbol(CADR(args));`
51	`Rboolean realIndx = n > INT_MAX;`	51	`bool realIndx = n > INT_MAX;`
52		52
53	`SEXP ans = PROTECT(allocVector(VECSXP, n));`	53	`SEXP ans = PROTECT(allocVector(VECSXP, n));`
54	`SEXP names = getAttrib(XX, R_NamesSymbol);`	54	`SEXP names = getAttrib(XX, R_NamesSymbol);`
55	`if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);`	55	`if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);`
56		56
Line 97...	Line 97...
97	`SEXP R_fcall, ans, names = R_NilValue, rowNames = R_NilValue,`	97	`SEXP R_fcall, ans, names = R_NilValue, rowNames = R_NilValue,`
98	`X, XX, FUN, value, dim_v;`	98	`X, XX, FUN, value, dim_v;`
99	`R_xlen_t i, n;`	99	`R_xlen_t i, n;`
100	`int commonLen;`	100	`int commonLen;`
101	`int useNames, rnk_v = -1; // = array_rank(value) := length(dim(value))`	101	`int useNames, rnk_v = -1; // = array_rank(value) := length(dim(value))`
102	`Rboolean array_value;`	102	`bool array_value;`
103	`SEXPTYPE commonType;`	103	`SEXPTYPE commonType;`
104	`PROTECT_INDEX index = 0; /* initialize to avoid a warning */`	104	`PROTECT_INDEX index = 0; /* initialize to avoid a warning */`
105		105
106	`checkArity(op, args);`	106	`checkArity(op, args);`
107	`PROTECT(X = CAR(args));`	107	`PROTECT(X = CAR(args));`
Line 114...	Line 114...
114	`// FIXME: does not protect against length > 1`	114	`// FIXME: does not protect against length > 1`
115	`if (useNames == NA_LOGICAL) error(_("invalid '%s' value"), "USE.NAMES");`	115	`if (useNames == NA_LOGICAL) error(_("invalid '%s' value"), "USE.NAMES");`
116		116
117	`n = xlength(XX);`	117	`n = xlength(XX);`
118	`if (n == NA_INTEGER) error(_("invalid length"));`	118	`if (n == NA_INTEGER) error(_("invalid length"));`
119	`Rboolean realIndx = n > INT_MAX;`	119	`bool realIndx = n > INT_MAX;`
120		120
121	`commonLen = length(value);`	121	`commonLen = length(value);`
122	`if (commonLen > 1 && n > INT_MAX)`	122	`if (commonLen > 1 && n > INT_MAX)`
123	`error(_("long vectors are not supported for matrix/array results"));`	123	`error(_("long vectors are not supported for matrix/array results"));`
124	`commonType = TYPEOF(value);`	124	`commonType = TYPEOF(value);`
Line 177...	Line 177...
177	`if (length(val) != commonLen)`	177	`if (length(val) != commonLen)`
178	`error(_("values must be length %d,\n but FUN(X[[%lld]]) result is length %d"),`	178	`error(_("values must be length %d,\n but FUN(X[[%lld]]) result is length %d"),`
179	`commonLen, (long long)i+1, length(val));`	179	`commonLen, (long long)i+1, length(val));`
180	`valType = TYPEOF(val);`	180	`valType = TYPEOF(val);`
181	`if (valType != commonType) {`	181	`if (valType != commonType) {`
182	`Rboolean okay = FALSE;`	182	`bool okay = false;`
183	`switch (commonType) {`	183	`switch (commonType) {`
184	`case CPLXSXP: okay = (valType == REALSXP) \|\| (valType == INTSXP)`	184	`case CPLXSXP: okay = (valType == REALSXP) \|\| (valType == INTSXP)`
185	`\|\| (valType == LGLSXP); break;`	185	`\|\| (valType == LGLSXP); break;`
186	`case REALSXP: okay = (valType == INTSXP) \|\| (valType == LGLSXP); break;`	186	`case REALSXP: okay = (valType == INTSXP) \|\| (valType == LGLSXP); break;`
187	`case INTSXP: okay = (valType == LGLSXP); break;`	187	`case INTSXP: okay = (valType == LGLSXP); break;`
Line 282...	Line 282...
282	`return ans;`	282	`return ans;`
283	`}`	283	`}`
284		284
285	`// Apply FUN() to X recursively; workhorse of rapply()`	285	`// Apply FUN() to X recursively; workhorse of rapply()`
286	`static SEXP do_one(SEXP X, SEXP FUN, SEXP classes, SEXP deflt,`	286	`static SEXP do_one(SEXP X, SEXP FUN, SEXP classes, SEXP deflt,`
287	`Rboolean replace, SEXP rho)`	287	`bool replace, SEXP rho)`
288	`{`	288	`{`
289	`SEXP ans, names, klass;`	289	`SEXP ans, names, klass;`
290	`Rboolean matched = FALSE;`	290	`bool matched = false;`
291		291
292	`/* if X is a list, recurse. Otherwise if it matches classes call f */`	292	`/* if X is a list, recurse. Otherwise if it matches classes call f */`
293	`if(X == R_NilValue \|\| isVectorList(X)) {`	293	`if(X == R_NilValue \|\| isVectorList(X)) {`
294	`R_xlen_t n = xlength(X);`	294	`R_xlen_t n = xlength(X);`
295	`if (replace) {`	295	`if (replace) {`
Line 304...	Line 304...
304	`deflt, replace, rho));`	304	`deflt, replace, rho));`
305	`UNPROTECT(1);`	305	`UNPROTECT(1);`
306	`return ans;`	306	`return ans;`
307	`}`	307	`}`
308	`if(strcmp(CHAR(STRING_ELT(classes, 0)), "ANY") == 0) /* ASCII */`	308	`if(strcmp(CHAR(STRING_ELT(classes, 0)), "ANY") == 0) /* ASCII */`
309	`matched = TRUE;`	309	`matched = true;`
310	`else {`	310	`else {`
311	`PROTECT(klass = R_data_class(X, FALSE));`	311	`PROTECT(klass = R_data_class(X, false));`
312	`for(int i = 0; i < LENGTH(klass); i++)`	312	`for(int i = 0; i < LENGTH(klass); i++)`
313	`for(int j = 0; j < length(classes); j++)`	313	`for(int j = 0; j < length(classes); j++)`
314	`if(Seql(STRING_ELT(klass, i), STRING_ELT(classes, j)))`	314	`if(Seql(STRING_ELT(klass, i), STRING_ELT(classes, j)))`
315	`matched = TRUE;`	315	`matched = true;`
316	`UNPROTECT(1);`	316	`UNPROTECT(1);`
317	`}`	317	`}`
318	`if(matched) {`	318	`if(matched) {`
319	`/* This stores value to which the function is to be applied in`	319	`/* This stores value to which the function is to be applied in`
320	`a variable X in the environment of the rapply closure call`	320	`a variable X in the environment of the rapply closure call`
Line 347...	Line 347...
347	`classes = CAR(args); args = CDR(args);`	347	`classes = CAR(args); args = CDR(args);`
348	`if(!isString(classes)) error(_("invalid '%s' argument"), "classes");`	348	`if(!isString(classes)) error(_("invalid '%s' argument"), "classes");`
349	`deflt = CAR(args); args = CDR(args);`	349	`deflt = CAR(args); args = CDR(args);`
350	`how = CAR(args);`	350	`how = CAR(args);`
351	`if(!isString(how)) error(_("invalid '%s' argument"), "how");`	351	`if(!isString(how)) error(_("invalid '%s' argument"), "how");`
352	`Rboolean replace = strcmp(CHAR(STRING_ELT(how, 0)), "replace") == 0; /* ASCII */`	352	`bool replace = strcmp(CHAR(STRING_ELT(how, 0)), "replace") == 0; /* ASCII */`
353	`R_xlen_t n = xlength(X);`	353	`R_xlen_t n = xlength(X);`
354	`if (replace) {`	354	`if (replace) {`
355	`PROTECT(ans = shallow_duplicate(X));`	355	`PROTECT(ans = shallow_duplicate(X));`
356	`} else {`	356	`} else {`
357	`PROTECT(ans = allocVector(VECSXP, n));`	357	`PROTECT(ans = allocVector(VECSXP, n));`
Line 378...	Line 378...
378	`case EXPRSXP: {`	378	`case EXPRSXP: {`
379	`int n = LENGTH(X), ans = NA_LOGICAL;`	379	`int n = LENGTH(X), ans = NA_LOGICAL;`
380	`for(int i = 0; i < n; i++) {`	380	`for(int i = 0; i < n; i++) {`
381	`int isLF = islistfactor(VECTOR_ELT(X, i));`	381	`int isLF = islistfactor(VECTOR_ELT(X, i));`
382	`if(!isLF)`	382	`if(!isLF)`
383	`return FALSE;`	383	`return false;`
384	`else if(isLF == TRUE)`	384	`else if(isLF == true)`
385	`ans = TRUE;`	385	`ans = true;`
386	`// else isLF is NA`	386	`// else isLF is NA`
387	`}`	387	`}`
388	`return ans;`	388	`return ans;`
389	`}`	389	`}`
390	`default:`	390	`default:`
Line 397...	Line 397...
397	`// currently only called from unlist()`	397	`// currently only called from unlist()`
398	`attribute_hidden SEXP do_islistfactor(SEXP call, SEXP op, SEXP args, SEXP rho)`	398	`attribute_hidden SEXP do_islistfactor(SEXP call, SEXP op, SEXP args, SEXP rho)`
399	`{`	399	`{`
400	`checkArity(op, args);`	400	`checkArity(op, args);`
401	`SEXP X = CAR(args);`	401	`SEXP X = CAR(args);`
402	`Rboolean recursive = asRbool(CADR(args), call);`	402	`bool recursive = asBool2(CADR(args), call);`
403	`int n = length(X);`	403	`int n = length(X);`
404	`if(n == 0 \|\| !isVectorList(X))`	404	`if(n == 0 \|\| !isVectorList(X))`
405	`return ScalarLogical(FALSE);`	405	`return ScalarLogical(false);`
406		406
407	`if(!recursive) {`	407	`if(!recursive) {`
408	`for(int i = 0; i < n; i++)`	408	`for(int i = 0; i < n; i++)`
409	`if(!isFactor(VECTOR_ELT(X, i)))`	409	`if(!isFactor(VECTOR_ELT(X, i)))`
410	`return ScalarLogical(FALSE);`	410	`return ScalarLogical(false);`
411		411
412	`return ScalarLogical(TRUE);`	412	`return ScalarLogical(true);`
413	`}`	413	`}`
414	`else { // recursive: isVectorList(X) <==> X is VECSXP or EXPRSXP`	414	`else { // recursive: isVectorList(X) <==> X is VECSXP or EXPRSXP`
415	`return ScalarLogical((islistfactor(X) == TRUE) ? TRUE : FALSE);`	415	`return ScalarLogical((islistfactor(X) == true) ? true : false);`
416	`}`	416	`}`
417	`}`	417	`}`

The R Project SVN R

(root)/trunk/src/main/apply.c @ 28362 – Rev 87838 → 87863