The R Project SVN R

Rev

Rev 36990 | Rev 38979 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 36990 Rev 37355
Line 32... Line 32...
32 
#include <Rmath.h>
 32 
#include <Rmath.h>
33 
 
 33 
 
34 
static SEXP
 34 
static SEXP
35 
cross(SEXP s, SEXP t)
 35 
cross(SEXP s, SEXP t)
36 
{
 36 
{
37 
    SEXP a, la, ls, lt;
 37 
    SEXP a, la, ls, lt, rs, rt;
38 
    int i, j, k, n, nls, nlt, vs, vt;
 38 
    int i, j, k, n, nls, nlt, vs, vt;
39 
 
 39 
 
40 
    n = length(s);
 40 
    n = length(s);
- 
 
 41 
    ls = getAttrib(s, R_LevelsSymbol);
- 
 
 42 
    lt = getAttrib(t, R_LevelsSymbol);
41 
    nls = nlevels(s);
 43 
    nls = LENGTH(ls);
42 
    nlt = nlevels(t);
 44 
    nlt = LENGTH(lt);
43 
    PROTECT(a = allocVector(INTSXP, n));
 45 
    PROTECT(a = allocVector(INTSXP, n));
- 
 
 46 
    PROTECT(rs = coerceVector(s, INTSXP));
- 
 
 47 
    PROTECT(rt = coerceVector(t, INTSXP));
44 
    for (i = 0; i < n; i++) {
 48 
    for (i = 0; i < n; i++) {
45 
	vs = INTEGER(s)[i];
 49 
	vs = INTEGER(rs)[i];
46 
	vt = INTEGER(t)[i];
 50 
	vt = INTEGER(rt)[i];
47 
	if ((vs == NA_INTEGER) || (vt == NA_INTEGER))
 51 
	if ((vs == NA_INTEGER) || (vt == NA_INTEGER))
48 
	    INTEGER(a)[i] = NA_INTEGER;
 52 
	    INTEGER(a)[i] = NA_INTEGER;
49 
	else
 53 
	else
50 
	    INTEGER(a)[i] = vt + (vs - 1) * nlt;
 54 
	    INTEGER(a)[i] = vt + (vs - 1) * nlt;
51 
    }
 55 
    }
52 
    ls = getAttrib(s, R_LevelsSymbol);
 - 
 
53 
    lt = getAttrib(t, R_LevelsSymbol);
 56 
    UNPROTECT(2);
54 
    if (!isNull(ls) && !isNull(lt)) {
 57 
    if (!isNull(ls) && !isNull(lt)) {
55 
	PROTECT(la = allocVector(STRSXP, nls * nlt));
 58 
	PROTECT(la = allocVector(STRSXP, nls * nlt));
56 
	k = 0;
 59 
	k = 0;
57 
	for (i = 0; i < nls; i++) {
 60 
	for (i = 0; i < nls; i++) {
58 
	    vs = strlen(CHAR(STRING_ELT(ls, i)));
 61 
	    vs = strlen(CHAR(STRING_ELT(ls, i)));
Line 119... Line 122...
119 
}
 122 
}
120 
 
 123 
 
121 
SEXP attribute_hidden do_seq(SEXP call, SEXP op, SEXP args, SEXP rho)
 124 
SEXP attribute_hidden do_seq(SEXP call, SEXP op, SEXP args, SEXP rho)
122 
{
 125 
{
123 
    checkArity(op, args);
 126 
    checkArity(op, args);
124 
    if (isFactor(CAR(args)) && isFactor(CADR(args))) {
 127 
    if (inherits(CAR(args), "factor") && inherits(CADR(args), "factor")) {
125 
	if (length(CAR(args)) != length(CADR(args)))
 128 
	if (length(CAR(args)) != length(CADR(args)))
126 
	    errorcall(call, _("unequal factor lengths"));
 129 
	    errorcall(call, _("unequal factor lengths"));
127 
	return(cross(CAR(args), CADR(args)));
 130 
	return(cross(CAR(args), CADR(args)));
128 
    }
 131 
    }
129 
    return seq(call, CAR(args), CADR(args));
 132 
    return seq(call, CAR(args), CADR(args));