The R Project SVN R

Rev

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

Rev 36990 Rev 37341
Line 25... Line 25...
25 
 
 25 
 
26 
SEXP attribute_hidden do_split(SEXP call, SEXP op, SEXP args, SEXP env)
 26 
SEXP attribute_hidden do_split(SEXP call, SEXP op, SEXP args, SEXP env)
27 
{
 27 
{
28 
    SEXP x, f, counts, vec, nm, nmj;
 28 
    SEXP x, f, counts, vec, nm, nmj;
29 
    int i, j, k, nobs, nlevs, nfac;
 29 
    int i, j, k, nobs, nlevs, nfac;
- 
 
 30 
    double d;
30 
    Rboolean have_names;
 31 
    Rboolean have_names;
31 
 
 32 
 
32 
    checkArity(op, args);
 33 
    checkArity(op, args);
33 
 
 34 
 
34 
    x = CAR(args);
 35 
    x = CAR(args);
35 
    f = CADR(args);
 36 
    f = CADR(args);
36 
    if (!isVector(x))
 37 
    if (!isVector(x))
37 
	errorcall(call, _("first argument must be a vector"));
 38 
	errorcall(call, _("first argument must be a vector"));
- 
 
 39 
    /* was isFactor, but this need not be integer */
38 
    if (!isFactor(f))
 40 
    if (!inherits(f, "factor"))
39 
	errorcall(call, _("second argument must be a factor"));
 41 
	errorcall(call, _("second argument must be a factor"));
40 
    nlevs = nlevels(f);
 42 
    nlevs = LENGTH(getAttrib(f, R_LevelsSymbol));
41 
    nfac = LENGTH(CADR(args));
 43 
    nfac = LENGTH(CADR(args));
42 
    nobs = LENGTH(CAR(args));
 44 
    nobs = LENGTH(CAR(args));
43 
    if (nobs <= 0)
 45 
    if (nobs <= 0)
44 
	return R_NilValue;
 46 
	return R_NilValue;
45 
    if (nfac <= 0)
 47 
    if (nfac <= 0)
Line 50... Line 52...
50 
    have_names = nm != R_NilValue;
 52 
    have_names = nm != R_NilValue;
51 
    PROTECT(counts = allocVector(INTSXP, nlevs));
 53 
    PROTECT(counts = allocVector(INTSXP, nlevs));
52 
    for (i = 0; i < nlevs; i++)
 54 
    for (i = 0; i < nlevs; i++)
53 
	INTEGER(counts)[i] = 0;
 55 
	INTEGER(counts)[i] = 0;
54 
    for (i = 0; i < nobs; i++) {
 56 
    for (i = 0; i < nobs; i++) {
- 
 
 57 
	if(TYPEOF(f) == REALSXP) {
55 
	j = INTEGER(f)[i % nfac];
 58 
	    d = REAL(f)[i % nfac];
- 
 
 59 
	    j  = R_FINITE(d) ? (int) d :  NA_INTEGER;
56 
	if (j != NA_INTEGER) {
 60 
	} else j = INTEGER(f)[i % nfac];
57 
	    INTEGER(counts)[j - 1] += 1;
 61 
	if (j != NA_INTEGER) INTEGER(counts)[j - 1]++;
58 
	}
 - 
 
59 
    }
 62 
    }
60 
    /* Allocate a generic vector to hold the results. */
 63 
    /* Allocate a generic vector to hold the results. */
61 
    /* The i-th element will hold the split-out data */
 64 
    /* The i-th element will hold the split-out data */
62 
    /* for the ith group. */
 65 
    /* for the ith group. */
63 
    PROTECT(vec = allocVector(VECSXP, nlevs));
 66 
    PROTECT(vec = allocVector(VECSXP, nlevs));
Line 70... Line 73...
70 
		      allocVector(STRSXP, INTEGER(counts)[i]));
 73 
		      allocVector(STRSXP, INTEGER(counts)[i]));
71 
    }
 74 
    }
72 
    for (i = 0; i < nlevs; i++)
 75 
    for (i = 0; i < nlevs; i++)
73 
	INTEGER(counts)[i] = 0;
 76 
	INTEGER(counts)[i] = 0;
74 
    for (i = 0;  i < nobs; i++) {
 77 
    for (i = 0;  i < nobs; i++) {
- 
 
 78 
	if(TYPEOF(f) == REALSXP) {
- 
 
 79 
	    d = REAL(f)[i % nfac];
- 
 
 80 
	    j  = R_FINITE(d) ? (int) d :  NA_INTEGER;
75 
	j = INTEGER(f)[i % nfac];
 81 
	} else j = INTEGER(f)[i % nfac];
76 
	if (j != NA_INTEGER) {
 82 
	if (j != NA_INTEGER) {
77 
	    k = INTEGER(counts)[j - 1];
 83 
	    k = INTEGER(counts)[j - 1];
78 
	    switch (TYPEOF(x)) {
 84 
	    switch (TYPEOF(x)) {
79 
	    case LGLSXP:
 85 
	    case LGLSXP:
80 
	    case INTSXP:
 86 
	    case INTSXP: