The R Project SVN R

Rev

Rev 10172 | Rev 31872 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
2 r 1 
/*
2 
 *  R : A Computer Langage for Statistical Data Analysis
3 
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
4 
 *
5 
 *  This program is free software; you can redistribute it and/or modify
6 
 *  it under the terms of the GNU General Public License as published by
7 
 *  the Free Software Foundation; either version 2 of the License, or
8 
 *  (at your option) any later version.
9 
 *
10 
 *  This program is distributed in the hope that it will be useful,
11 
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
12 
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13 
 *  GNU General Public License for more details.
14 
 *
15 
 *  You should have received a copy of the GNU General Public License
16 
 *  along with this program; if not, write to the Free Software
5458 ripley 17 
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
2 r 18 
 */
19 
 
5187 hornik 20 
#ifdef HAVE_CONFIG_H
7701 hornik 21 
#include <config.h>
5187 hornik 22 
#endif
23 
 
2 r 24 
#include "Defn.h"
25 
 
26 
SEXP do_split(SEXP call, SEXP op, SEXP args, SEXP env)
27 
{
2342 maechler 28 
    SEXP x, f, counts, vec;
1839 ihaka 29 
    int i, j, k, nobs, nlevs, nfac;
2 r 30 
 
1839 ihaka 31 
    checkArity(op, args);
2342 maechler 32 
 
1839 ihaka 33 
    x = CAR(args);
34 
    f = CADR(args);
35 
    if (!isVector(x))
5731 ripley 36 
	errorcall(call, "first argument must be a vector");
1839 ihaka 37 
    if (!isFactor(f))
5731 ripley 38 
	errorcall(call, "second argument must be a factor");
1839 ihaka 39 
    nlevs = nlevels(f);
40 
    nfac = LENGTH(CADR(args));
41 
    nobs = LENGTH(CAR(args));
42 
    if (nobs <= 0)
43 
	return R_NilValue;
44 
    if (nfac <= 0)
2342 maechler 45 
	errorcall(call, "Group length is 0 but data length > 0");
26571 rgentlem 46 
    if (nobs % nfac != 0)
47 
	warningcall(call, "data length is not a multiple of split variable");
1839 ihaka 48 
    PROTECT(counts = allocVector(INTSXP, nlevs));
49 
    for (i = 0; i < nlevs; i++)
50 
	INTEGER(counts)[i] = 0;
51 
    for (i = 0; i < nobs; i++) {
52 
	j = INTEGER(f)[i % nfac];
53 
	if (j != NA_INTEGER) {
54 
	    INTEGER(counts)[j - 1] += 1;
2 r 55 
	}
1839 ihaka 56 
    }
57 
    /* Allocate a generic vector to hold the results. */
58 
    /* The i-th element will hold the split-out data */
59 
    /* for the ith group. */
60 
    PROTECT(vec = allocVector(VECSXP, nlevs));
61 
    for (i = 0;  i< nlevs; i++) {
10172 luke 62 
	SET_VECTOR_ELT(vec, i, allocVector(TYPEOF(x), INTEGER(counts)[i]));
63 
	setAttrib(VECTOR_ELT(vec, i), R_LevelsSymbol,
1839 ihaka 64 
		  getAttrib(x, R_LevelsSymbol));
65 
    }
66 
    for (i = 0; i < nlevs; i++)
67 
	INTEGER(counts)[i] = 0;
68 
    for (i = 0;  i< nobs; i++) {
69 
	j = INTEGER(f)[i % nfac];
70 
	if (j != NA_INTEGER) {
71 
	    k = INTEGER(counts)[j - 1];
72 
	    switch (TYPEOF(x)) {
73 
	    case LGLSXP:
74 
	    case INTSXP:
10172 luke 75 
		INTEGER(VECTOR_ELT(vec, j - 1))[k] = INTEGER(x)[i];
1839 ihaka 76 
		break;
77 
	    case REALSXP:
10172 luke 78 
		REAL(VECTOR_ELT(vec, j - 1))[k] = REAL(x)[i];
1839 ihaka 79 
		break;
80 
	    case CPLXSXP:
10172 luke 81 
		COMPLEX(VECTOR_ELT(vec, j - 1))[k] = COMPLEX(x)[i];
1839 ihaka 82 
		break;
83 
	    case STRSXP:
10172 luke 84 
		SET_STRING_ELT(VECTOR_ELT(vec, j - 1), k, STRING_ELT(x, i));
1839 ihaka 85 
		break;
86 
	    }
87 
	    INTEGER(counts)[j - 1] += 1;
544 pd 88 
	}
1839 ihaka 89 
    }
90 
    /* Now transfer the results from the vector */
91 
    /* into a dotted-pair list.  When structures */
92 
    /* are full based on vectors this won't be needed. */
93 
    setAttrib(vec, R_NamesSymbol, getAttrib(f, R_LevelsSymbol));
94 
    UNPROTECT(2);
95 
    return vec;
2 r 96 
}