The R Project SVN R

Rev

Rev 60667 | Rev 68923 | 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
59036 ripley 4 
 *  Copuright (C) 2006 The R Core Team
2 r 5 
 *
6 
 *  This program is free software; you can redistribute it and/or modify
7 
 *  it under the terms of the GNU General Public License as published by
8 
 *  the Free Software Foundation; either version 2 of the License, or
9 
 *  (at your option) any later version.
10 
 *
11 
 *  This program is distributed in the hope that it will be useful,
12 
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
13 
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14 
 *  GNU General Public License for more details.
15 
 *
16 
 *  You should have received a copy of the GNU General Public License
42307 ripley 17 
 *  along with this program; if not, a copy is available at
18 
 *  http://www.r-project.org/Licenses/
2 r 19 
 */
20 
 
5187 hornik 21 
#ifdef HAVE_CONFIG_H
7701 hornik 22 
#include <config.h>
5187 hornik 23 
#endif
24 
 
2 r 25 
#include "Defn.h"
60667 ripley 26 
#include <Internal.h>
2 r 27 
 
36990 ripley 28 
SEXP attribute_hidden do_split(SEXP call, SEXP op, SEXP args, SEXP env)
2 r 29 
{
31872 ripley 30 
    SEXP x, f, counts, vec, nm, nmj;
31 
    Rboolean have_names;
2 r 32 
 
1839 ihaka 33 
    checkArity(op, args);
2342 maechler 34 
 
1839 ihaka 35 
    x = CAR(args);
36 
    f = CADR(args);
37 
    if (!isVector(x))
41686 ripley 38 
	error(_("first argument must be a vector"));
37349 ripley 39 
    if (!isFactor(f))
41686 ripley 40 
	error(_("second argument must be a factor"));
60241 ripley 41 
    int nlevs = nlevels(f);
42 
    R_xlen_t nfac = XLENGTH(CADR(args));
43 
    R_xlen_t nobs = XLENGTH(CAR(args));
44220 ripley 44 
    if (nfac <= 0 && nobs > 0)
60844 ripley 45 
	error(_("group length is 0 but data length > 0"));
44220 ripley 46 
    if (nfac > 0 && (nobs % nfac) != 0)
41686 ripley 47 
	warning(_("data length is not a multiple of split variable"));
31872 ripley 48 
    nm = getAttrib(x, R_NamesSymbol);
49 
    have_names = nm != R_NilValue;
1839 ihaka 50 
    PROTECT(counts = allocVector(INTSXP, nlevs));
60241 ripley 51 
    for (int i = 0; i < nlevs; i++) INTEGER(counts)[i] = 0;
52 
    for (R_xlen_t i = 0; i < nobs; i++) {
53 
	int j = INTEGER(f)[i % nfac];
51908 murdoch 54 
	if (j != NA_INTEGER) {
55 
	    /* protect against malformed factors */
56 
	    if (j > nlevs || j < 1) error(_("factor has bad level"));
57 
	    INTEGER(counts)[j - 1]++;
58 
	}
1839 ihaka 59 
    }
60 
    /* Allocate a generic vector to hold the results. */
61 
    /* The i-th element will hold the split-out data */
62 
    /* for the ith group. */
63 
    PROTECT(vec = allocVector(VECSXP, nlevs));
60241 ripley 64 
    for (R_xlen_t i = 0;  i < nlevs; i++) {
10172 luke 65 
	SET_VECTOR_ELT(vec, i, allocVector(TYPEOF(x), INTEGER(counts)[i]));
66 
	setAttrib(VECTOR_ELT(vec, i), R_LevelsSymbol,
1839 ihaka 67 
		  getAttrib(x, R_LevelsSymbol));
31872 ripley 68 
	if(have_names)
69 
	    setAttrib(VECTOR_ELT(vec, i), R_NamesSymbol,
70 
		      allocVector(STRSXP, INTEGER(counts)[i]));
1839 ihaka 71 
    }
60241 ripley 72 
    for (int i = 0; i < nlevs; i++) INTEGER(counts)[i] = 0;
73 
    for (R_xlen_t i = 0;  i < nobs; i++) {
74 
	int j = INTEGER(f)[i % nfac];
1839 ihaka 75 
	if (j != NA_INTEGER) {
60241 ripley 76 
	    int k = INTEGER(counts)[j - 1];
1839 ihaka 77 
	    switch (TYPEOF(x)) {
78 
	    case LGLSXP:
79 
	    case INTSXP:
10172 luke 80 
		INTEGER(VECTOR_ELT(vec, j - 1))[k] = INTEGER(x)[i];
1839 ihaka 81 
		break;
82 
	    case REALSXP:
10172 luke 83 
		REAL(VECTOR_ELT(vec, j - 1))[k] = REAL(x)[i];
1839 ihaka 84 
		break;
85 
	    case CPLXSXP:
10172 luke 86 
		COMPLEX(VECTOR_ELT(vec, j - 1))[k] = COMPLEX(x)[i];
1839 ihaka 87 
		break;
88 
	    case STRSXP:
10172 luke 89 
		SET_STRING_ELT(VECTOR_ELT(vec, j - 1), k, STRING_ELT(x, i));
1839 ihaka 90 
		break;
31869 ripley 91 
	    case VECSXP:
92 
		SET_VECTOR_ELT(VECTOR_ELT(vec, j - 1), k, VECTOR_ELT(x, i));
93 
		break;
94 
	    case RAWSXP:
95 
		RAW(VECTOR_ELT(vec, j - 1))[k] = RAW(x)[i];
96 
		break;
97 
	    default:
31908 ripley 98 
		UNIMPLEMENTED_TYPE("split", x);
1839 ihaka 99 
	    }
31872 ripley 100 
	    if(have_names) {
101 
		nmj = getAttrib(VECTOR_ELT(vec, j - 1), R_NamesSymbol);
102 
		SET_STRING_ELT(nmj, k, STRING_ELT(nm, i));
103 
	    }
1839 ihaka 104 
	    INTEGER(counts)[j - 1] += 1;
544 pd 105 
	}
1839 ihaka 106 
    }
107 
    setAttrib(vec, R_NamesSymbol, getAttrib(f, R_LevelsSymbol));
108 
    UNPROTECT(2);
109 
    return vec;
2 r 110 
}