The R Project SVN R

Rev

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

Rev 60844 Rev 68663
Line 22... Line 22...
22 
#include <config.h>
 22 
#include <config.h>
23 
#endif
 23 
#endif
24 
 
 24 
 
25 
#include "Defn.h"
 25 
#include "Defn.h"
26 
#include <Internal.h>
 26 
#include <Internal.h>
- 
 
 27 
#include <R_ext/Itermacros.h>
27 
 
 28 
 
28 
SEXP attribute_hidden do_split(SEXP call, SEXP op, SEXP args, SEXP env)
 29 
SEXP attribute_hidden do_split(SEXP call, SEXP op, SEXP args, SEXP env)
29 
{
 30 
{
30 
    SEXP x, f, counts, vec, nm, nmj;
 31 
    SEXP x, f, counts, vec, nm, nmj;
31 
    Rboolean have_names;
 32 
    Rboolean have_names;
Line 47... Line 48...
47 
	warning(_("data length is not a multiple of split variable"));
 48 
	warning(_("data length is not a multiple of split variable"));
48 
    nm = getAttrib(x, R_NamesSymbol);
 49 
    nm = getAttrib(x, R_NamesSymbol);
49 
    have_names = nm != R_NilValue;
 50 
    have_names = nm != R_NilValue;
50 
    PROTECT(counts = allocVector(INTSXP, nlevs));
 51 
    PROTECT(counts = allocVector(INTSXP, nlevs));
51 
    for (int i = 0; i < nlevs; i++) INTEGER(counts)[i] = 0;
 52 
    for (int i = 0; i < nlevs; i++) INTEGER(counts)[i] = 0;
52 
    for (R_xlen_t i = 0; i < nobs; i++) {
 53 
    R_xlen_t i, i1;
- 
 
 54 
    MOD_ITERATE1(nobs, nfac, i, i1, {
53 
	int j = INTEGER(f)[i % nfac];
 55 
	int j = INTEGER(f)[i1];
54 
	if (j != NA_INTEGER) {
 56 
	if (j != NA_INTEGER) {
55 
	    /* protect against malformed factors */
 57 
	    /* protect against malformed factors */
56 
	    if (j > nlevs || j < 1) error(_("factor has bad level"));
 58 
	    if (j > nlevs || j < 1) error(_("factor has bad level"));
57 
	    INTEGER(counts)[j - 1]++;
 59 
	    INTEGER(counts)[j - 1]++;
58 
	}
 60 
	}
59 
    }
 61 
    });
60 
    /* Allocate a generic vector to hold the results. */
 62 
    /* Allocate a generic vector to hold the results. */
61 
    /* The i-th element will hold the split-out data */
 63 
    /* The i-th element will hold the split-out data */
62 
    /* for the ith group. */
 64 
    /* for the ith group. */
63 
    PROTECT(vec = allocVector(VECSXP, nlevs));
 65 
    PROTECT(vec = allocVector(VECSXP, nlevs));
64 
    for (R_xlen_t i = 0;  i < nlevs; i++) {
 66 
    for (R_xlen_t i = 0;  i < nlevs; i++) {
Line 68... Line 70...
68 
	if(have_names)
 70 
	if(have_names)
69 
	    setAttrib(VECTOR_ELT(vec, i), R_NamesSymbol,
 71 
	    setAttrib(VECTOR_ELT(vec, i), R_NamesSymbol,
70 
		      allocVector(STRSXP, INTEGER(counts)[i]));
 72 
		      allocVector(STRSXP, INTEGER(counts)[i]));
71 
    }
 73 
    }
72 
    for (int i = 0; i < nlevs; i++) INTEGER(counts)[i] = 0;
 74 
    for (int i = 0; i < nlevs; i++) INTEGER(counts)[i] = 0;
73 
    for (R_xlen_t i = 0;  i < nobs; i++) {
 75 
    MOD_ITERATE1(nobs, nfac, i, i1, {
74 
	int j = INTEGER(f)[i % nfac];
 76 
	int j = INTEGER(f)[i1];
75 
	if (j != NA_INTEGER) {
 77 
	if (j != NA_INTEGER) {
76 
	    int k = INTEGER(counts)[j - 1];
 78 
	    int k = INTEGER(counts)[j - 1];
77 
	    switch (TYPEOF(x)) {
 79 
	    switch (TYPEOF(x)) {
78 
	    case LGLSXP:
 80 
	    case LGLSXP:
79 
	    case INTSXP:
 81 
	    case INTSXP:
Line 101... Line 103...
101 
		nmj = getAttrib(VECTOR_ELT(vec, j - 1), R_NamesSymbol);
 103 
		nmj = getAttrib(VECTOR_ELT(vec, j - 1), R_NamesSymbol);
102 
		SET_STRING_ELT(nmj, k, STRING_ELT(nm, i));
 104 
		SET_STRING_ELT(nmj, k, STRING_ELT(nm, i));
103 
	    }
 105 
	    }
104 
	    INTEGER(counts)[j - 1] += 1;
 106 
	    INTEGER(counts)[j - 1] += 1;
105 
	}
 107 
	}
106 
    }
 108 
    });
107 
    setAttrib(vec, R_NamesSymbol, getAttrib(f, R_LevelsSymbol));
 109 
    setAttrib(vec, R_NamesSymbol, getAttrib(f, R_LevelsSymbol));
108 
    UNPROTECT(2);
 110 
    UNPROTECT(2);
109 
    return vec;
 111 
    return vec;
110 
}
 112 
}