The R Project SVN R

Rev

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

Rev 37341 Rev 37349
Line 1... Line 1...
1 
/*
 1 
/*
2 
 *  R : A Computer Langage for Statistical Data Analysis
 2 
 *  R : A Computer Langage for Statistical Data Analysis
3 
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
 3 
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
- 
 
 4 
 *  Copuright (C) 2006 The R Core Development Team
4 
 *
 5 
 *
5 
 *  This program is free software; you can redistribute it and/or modify
 6 
 *  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 
 *  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 
 *  the Free Software Foundation; either version 2 of the License, or
8 
 *  (at your option) any later version.
 9 
 *  (at your option) any later version.
Line 25... Line 26...
25 
 
 26 
 
26 
SEXP attribute_hidden do_split(SEXP call, SEXP op, SEXP args, SEXP env)
 27 
SEXP attribute_hidden do_split(SEXP call, SEXP op, SEXP args, SEXP env)
27 
{
 28 
{
28 
    SEXP x, f, counts, vec, nm, nmj;
 29 
    SEXP x, f, counts, vec, nm, nmj;
29 
    int i, j, k, nobs, nlevs, nfac;
 30 
    int i, j, k, nobs, nlevs, nfac;
30 
    double d;
 - 
 
31 
    Rboolean have_names;
 31 
    Rboolean have_names;
32 
 
 32 
 
33 
    checkArity(op, args);
 33 
    checkArity(op, args);
34 
 
 34 
 
35 
    x = CAR(args);
 35 
    x = CAR(args);
36 
    f = CADR(args);
 36 
    f = CADR(args);
37 
    if (!isVector(x))
 37 
    if (!isVector(x))
38 
	errorcall(call, _("first argument must be a vector"));
 38 
	errorcall(call, _("first argument must be a vector"));
39 
    /* was isFactor, but this need not be integer */
 - 
 
40 
    if (!inherits(f, "factor"))
 39 
    if (!isFactor(f))
41 
	errorcall(call, _("second argument must be a factor"));
 40 
	errorcall(call, _("second argument must be a factor"));
42 
    nlevs = LENGTH(getAttrib(f, R_LevelsSymbol));
 41 
    nlevs = nlevels(f);
43 
    nfac = LENGTH(CADR(args));
 42 
    nfac = LENGTH(CADR(args));
44 
    nobs = LENGTH(CAR(args));
 43 
    nobs = LENGTH(CAR(args));
45 
    if (nobs <= 0)
 44 
    if (nobs <= 0)
46 
	return R_NilValue;
 45 
	return R_NilValue;
47 
    if (nfac <= 0)
 46 
    if (nfac <= 0)
Line 49... Line 48...
49 
    if (nobs % nfac != 0)
 48 
    if (nobs % nfac != 0)
50 
	warningcall(call, _("data length is not a multiple of split variable"));
 49 
	warningcall(call, _("data length is not a multiple of split variable"));
51 
    nm = getAttrib(x, R_NamesSymbol);
 50 
    nm = getAttrib(x, R_NamesSymbol);
52 
    have_names = nm != R_NilValue;
 51 
    have_names = nm != R_NilValue;
53 
    PROTECT(counts = allocVector(INTSXP, nlevs));
 52 
    PROTECT(counts = allocVector(INTSXP, nlevs));
54 
    for (i = 0; i < nlevs; i++)
 53 
    for (i = 0; i < nlevs; i++) INTEGER(counts)[i] = 0;
55 
	INTEGER(counts)[i] = 0;
 - 
 
56 
    for (i = 0; i < nobs; i++) {
 54 
    for (i = 0; i < nobs; i++) {
57 
	if(TYPEOF(f) == REALSXP) {
 - 
 
58 
	    d = REAL(f)[i % nfac];
 - 
 
59 
	    j  = R_FINITE(d) ? (int) d :  NA_INTEGER;
 - 
 
60 
	} else j = INTEGER(f)[i % nfac];
 55 
	j = INTEGER(f)[i % nfac];
61 
	if (j != NA_INTEGER) INTEGER(counts)[j - 1]++;
 56 
	if (j != NA_INTEGER) INTEGER(counts)[j - 1]++;
62 
    }
 57 
    }
63 
    /* Allocate a generic vector to hold the results. */
 58 
    /* Allocate a generic vector to hold the results. */
64 
    /* The i-th element will hold the split-out data */
 59 
    /* The i-th element will hold the split-out data */
65 
    /* for the ith group. */
 60 
    /* for the ith group. */
Line 73... Line 68...
73 
		      allocVector(STRSXP, INTEGER(counts)[i]));
 68 
		      allocVector(STRSXP, INTEGER(counts)[i]));
74 
    }
 69 
    }
75 
    for (i = 0; i < nlevs; i++)
 70 
    for (i = 0; i < nlevs; i++)
76 
	INTEGER(counts)[i] = 0;
 71 
	INTEGER(counts)[i] = 0;
77 
    for (i = 0;  i < nobs; i++) {
 72 
    for (i = 0;  i < nobs; i++) {
78 
	if(TYPEOF(f) == REALSXP) {
 - 
 
79 
	    d = REAL(f)[i % nfac];
 - 
 
80 
	    j  = R_FINITE(d) ? (int) d :  NA_INTEGER;
 - 
 
81 
	} else j = INTEGER(f)[i % nfac];
 73 
	j = INTEGER(f)[i % nfac];
82 
	if (j != NA_INTEGER) {
 74 
	if (j != NA_INTEGER) {
83 
	    k = INTEGER(counts)[j - 1];
 75 
	    k = INTEGER(counts)[j - 1];
84 
	    switch (TYPEOF(x)) {
 76 
	    switch (TYPEOF(x)) {
85 
	    case LGLSXP:
 77 
	    case LGLSXP:
86 
	    case INTSXP:
 78 
	    case INTSXP: