The R Project SVN R

Rev

Rev 84211 | 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
87891 ripley 4 
 *  Copyright (C) 2006-2025 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 
 
84211 ripley 25 
#include <Defn.h>
60667 ripley 26 
#include <Internal.h>
68663 luke 27 
#include <R_ext/Itermacros.h>
2 r 28 
 
83446 ripley 29 
attribute_hidden SEXP do_split(SEXP call, SEXP op, SEXP args, SEXP env)
2 r 30 
{
31872 ripley 31 
    SEXP x, f, counts, vec, nm, nmj;
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);
87891 ripley 49 
    bool have_names = nm != R_NilValue;  // used in split-incl.c
71432 maechler 50 
 
51 
#ifdef LONG_VECTOR_SUPPORT
52 
    if (IS_LONG_VEC(x))
53 
# define _L_INTSXP_ REALSXP
54 
# define _L_INTEG_  REAL
55 
# define _L_int_    R_xlen_t
56 
# include "split-incl.c"
57 
 
58 
# undef _L_INTSXP_
59 
# undef _L_INTEG_
60 
# undef _L_int_
61 
    else
62 
#endif
63 
 
64 
# define _L_INTSXP_ INTSXP
65 
# define _L_INTEG_  INTEGER
66 
# define _L_int_    int
67 
# include "split-incl.c"
68 
 
69 
# undef _L_INTSXP_
70 
# undef _L_INTEG_
71 
# undef _L_int_
72 
 
1839 ihaka 73 
    setAttrib(vec, R_NamesSymbol, getAttrib(f, R_LevelsSymbol));
74 
    UNPROTECT(2);
75 
    return vec;
2 r 76 
}