The R Project SVN R

Rev

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

Rev Author Line No. Line
2 r 1 
/*
73256 maechler 2 
 *  R : A Computer Language for Statistical Data Analysis
2 r 3 
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
71432 maechler 4 
 *  Copyright (C) 2006-2016 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
68947 ripley 18 
 *  https://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>
68663 luke 27 
#include <R_ext/Itermacros.h>
2 r 28 
 
36990 ripley 29 
SEXP attribute_hidden do_split(SEXP call, SEXP op, SEXP args, SEXP env)
2 r 30 
{
31872 ripley 31 
    SEXP x, f, counts, vec, nm, nmj;
32 
    Rboolean have_names;
2 r 33 
 
1839 ihaka 34 
    checkArity(op, args);
2342 maechler 35 
 
1839 ihaka 36 
    x = CAR(args);
37 
    f = CADR(args);
38 
    if (!isVector(x))
41686 ripley 39 
	error(_("first argument must be a vector"));
37349 ripley 40 
    if (!isFactor(f))
41686 ripley 41 
	error(_("second argument must be a factor"));
60241 ripley 42 
    int nlevs = nlevels(f);
43 
    R_xlen_t nfac = XLENGTH(CADR(args));
44 
    R_xlen_t nobs = XLENGTH(CAR(args));
44220 ripley 45 
    if (nfac <= 0 && nobs > 0)
60844 ripley 46 
	error(_("group length is 0 but data length > 0"));
44220 ripley 47 
    if (nfac > 0 && (nobs % nfac) != 0)
41686 ripley 48 
	warning(_("data length is not a multiple of split variable"));
31872 ripley 49 
    nm = getAttrib(x, R_NamesSymbol);
50 
    have_names = nm != R_NilValue;
71432 maechler 51 
 
52 
#ifdef LONG_VECTOR_SUPPORT
53 
    if (IS_LONG_VEC(x))
54 
# define _L_INTSXP_ REALSXP
55 
# define _L_INTEG_  REAL
56 
# define _L_int_    R_xlen_t
57 
# include "split-incl.c"
58 
 
59 
# undef _L_INTSXP_
60 
# undef _L_INTEG_
61 
# undef _L_int_
62 
    else
63 
#endif
64 
 
65 
# define _L_INTSXP_ INTSXP
66 
# define _L_INTEG_  INTEGER
67 
# define _L_int_    int
68 
# include "split-incl.c"
69 
 
70 
# undef _L_INTSXP_
71 
# undef _L_INTEG_
72 
# undef _L_int_
73 
 
1839 ihaka 74 
    setAttrib(vec, R_NamesSymbol, getAttrib(f, R_LevelsSymbol));
75 
    UNPROTECT(2);
76 
    return vec;
2 r 77 
}